@@ -1,9 +1,31 @@
This file documents the revision history for Catalyst::Engine::Apache.
+1.16 2010-10-05 00:29:16
+ - No code changes.
+ - Don't ship .rej files in the dist.
+ - Convert to Dist::Zilla.
+
+1.15 2010-10-03 22:07:00
+ - Fix license info for debian et all.
+
+1.14
+ - No changes since dev release.
+
+1.13_01
+ - Update tests to pass again.
+ - Update tests to not throw warnings with newer versions of Catalyst.
+ - Fix $c->req->remote_user with this engine.
+ - Clarify use with non-standard ports.
+ - Fixes RT#61707, RT#61706, RT#61704, RT#36829
+
+1.13
+ - Workaround change in LWP that broke a cookie test (RT #40037)
+ - Update streaming test to latest 5.70
+
1.12 2008-02-20 09:00:00
- - Fixed bug where %2b in query parameter is doubly decoded to ' ', instead of '+'
+ - Fixed bug where %2b in query parameter is doubly decoded to ' ', instead of '+'
(Gavin Henry, Tatsuhiko Miyagawa)
- - Fixed bug where req->base and req->uri would include a port number when running
+ - Fixed bug where req->base and req->uri would include a port number when running
in SSL mode.
- Fixed warning when a non-trivial regex is used in a LocationMatch block.
(Steffen Schwigon)
@@ -0,0 +1,377 @@
+This software is copyright (c) 2010 by The "AUTHORS".
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+Terms of the Perl programming language system itself
+
+a) the GNU General Public License as published by the Free
+ Software Foundation; either version 1, or (at your option) any
+ later version, or
+b) the "Artistic License"
+
+--- The GNU General Public License, Version 1, February 1989 ---
+
+This software is Copyright (c) 2010 by The "AUTHORS".
+
+This is free software, licensed under:
+
+ The GNU General Public License, Version 1, February 1989
+
+ GNU GENERAL PUBLIC LICENSE
+ Version 1, February 1989
+
+ Copyright (C) 1989 Free Software Foundation, Inc.
+ 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The license agreements of most software companies try to keep users
+at the mercy of those companies. By contrast, our General Public
+License is intended to guarantee your freedom to share and change free
+software--to make sure the software is free for all its users. The
+General Public License applies to the Free Software Foundation's
+software and to any other program whose authors commit to using it.
+You can use it for your programs, too.
+
+ When we speak of free software, we are referring to freedom, not
+price. Specifically, the General Public License is designed to make
+sure that you have the freedom to give away or sell copies of free
+software, that you receive source code or can get it if you want it,
+that you can change the software or use pieces of it in new free
+programs; and that you know you can do these things.
+
+ To protect your rights, we need to make restrictions that forbid
+anyone to deny you these rights or to ask you to surrender the rights.
+These restrictions translate to certain responsibilities for you if you
+distribute copies of the software, or if you modify it.
+
+ For example, if you distribute copies of a such a program, whether
+gratis or for a fee, you must give the recipients all the rights that
+you have. You must make sure that they, too, receive or can get the
+source code. And you must tell them their rights.
+
+ We protect your rights with two steps: (1) copyright the software, and
+(2) offer you this license which gives you legal permission to copy,
+distribute and/or modify the software.
+
+ Also, for each author's protection and ours, we want to make certain
+that everyone understands that there is no warranty for this free
+software. If the software is modified by someone else and passed on, we
+want its recipients to know that what they have is not the original, so
+that any problems introduced by others will not reflect on the original
+authors' reputations.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+
+ GNU GENERAL PUBLIC LICENSE
+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+ 0. This License Agreement applies to any program or other work which
+contains a notice placed by the copyright holder saying it may be
+distributed under the terms of this General Public License. The
+"Program", below, refers to any such program or work, and a "work based
+on the Program" means either the Program or any work containing the
+Program or a portion of it, either verbatim or with modifications. Each
+licensee is addressed as "you".
+
+ 1. You may copy and distribute verbatim copies of the Program's source
+code as you receive it, in any medium, provided that you conspicuously and
+appropriately publish on each copy an appropriate copyright notice and
+disclaimer of warranty; keep intact all the notices that refer to this
+General Public License and to the absence of any warranty; and give any
+other recipients of the Program a copy of this General Public License
+along with the Program. You may charge a fee for the physical act of
+transferring a copy.
+
+ 2. You may modify your copy or copies of the Program or any portion of
+it, and copy and distribute such modifications under the terms of Paragraph
+1 above, provided that you also do the following:
+
+ a) cause the modified files to carry prominent notices stating that
+ you changed the files and the date of any change; and
+
+ b) cause the whole of any work that you distribute or publish, that
+ in whole or in part contains the Program or any part thereof, either
+ with or without modifications, to be licensed at no charge to all
+ third parties under the terms of this General Public License (except
+ that you may choose to grant warranty protection to some or all
+ third parties, at your option).
+
+ c) If the modified program normally reads commands interactively when
+ run, you must cause it, when started running for such interactive use
+ in the simplest and most usual way, to print or display an
+ announcement including an appropriate copyright notice and a notice
+ that there is no warranty (or else, saying that you provide a
+ warranty) and that users may redistribute the program under these
+ conditions, and telling the user how to view a copy of this General
+ Public License.
+
+ d) You may charge a fee for the physical act of transferring a
+ copy, and you may at your option offer warranty protection in
+ exchange for a fee.
+
+Mere aggregation of another independent work with the Program (or its
+derivative) on a volume of a storage or distribution medium does not bring
+the other work under the scope of these terms.
+
+ 3. You may copy and distribute the Program (or a portion or derivative of
+it, under Paragraph 2) in object code or executable form under the terms of
+Paragraphs 1 and 2 above provided that you also do one of the following:
+
+ a) accompany it with the complete corresponding machine-readable
+ source code, which must be distributed under the terms of
+ Paragraphs 1 and 2 above; or,
+
+ b) accompany it with a written offer, valid for at least three
+ years, to give any third party free (except for a nominal charge
+ for the cost of distribution) a complete machine-readable copy of the
+ corresponding source code, to be distributed under the terms of
+ Paragraphs 1 and 2 above; or,
+
+ c) accompany it with the information you received as to where the
+ corresponding source code may be obtained. (This alternative is
+ allowed only for noncommercial distribution and only if you
+ received the program in object code or executable form alone.)
+
+Source code for a work means the preferred form of the work for making
+modifications to it. For an executable file, complete source code means
+all the source code for all modules it contains; but, as a special
+exception, it need not include source code for modules which are standard
+libraries that accompany the operating system on which the executable
+file runs, or for standard header files or definitions files that
+accompany that operating system.
+
+ 4. You may not copy, modify, sublicense, distribute or transfer the
+Program except as expressly provided under this General Public License.
+Any attempt otherwise to copy, modify, sublicense, distribute or transfer
+the Program is void, and will automatically terminate your rights to use
+the Program under this License. However, parties who have received
+copies, or rights to use copies, from you under this General Public
+License will not have their licenses terminated so long as such parties
+remain in full compliance.
+
+ 5. By copying, distributing or modifying the Program (or any work based
+on the Program) you indicate your acceptance of this license to do so,
+and all its terms and conditions.
+
+ 6. Each time you redistribute the Program (or any work based on the
+Program), the recipient automatically receives a license from the original
+licensor to copy, distribute or modify the Program subject to these
+terms and conditions. You may not impose any further restrictions on the
+recipients' exercise of the rights granted herein.
+
+ 7. The Free Software Foundation may publish revised and/or new versions
+of the General Public License from time to time. Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Program
+specifies a version number of the license which applies to it and "any
+later version", you have the option of following the terms and conditions
+either of that version or of any later version published by the Free
+Software Foundation. If the Program does not specify a version number of
+the license, you may choose any version ever published by the Free Software
+Foundation.
+
+ 8. If you wish to incorporate parts of the Program into other free
+programs whose distribution conditions are different, write to the author
+to ask for permission. For software which is copyrighted by the Free
+Software Foundation, write to the Free Software Foundation; we sometimes
+make exceptions for this. Our decision will be guided by the two goals
+of preserving the free status of all derivatives of our free software and
+of promoting the sharing and reuse of software generally.
+
+ NO WARRANTY
+
+ 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
+REPAIR OR CORRECTION.
+
+ 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGES.
+
+ END OF TERMS AND CONDITIONS
+
+ Appendix: How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to humanity, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these
+terms.
+
+ To do so, attach the following notices to the program. It is safest to
+attach them to the start of each source file to most effectively convey
+the exclusion of warranty; and each file should have at least the
+"copyright" line and a pointer to where the full notice is found.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) 19yy <name of author>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 1, or (at your option)
+ any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software Foundation,
+ Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+ Gnomovision version 69, Copyright (C) 19xx name of author
+ Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the
+appropriate parts of the General Public License. Of course, the
+commands you use may be called something other than `show w' and `show
+c'; they could even be mouse-clicks or menu items--whatever suits your
+program.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary. Here a sample; alter the names:
+
+ Yoyodyne, Inc., hereby disclaims all copyright interest in the
+ program `Gnomovision' (a program to direct compilers to make passes
+ at assemblers) written by James Hacker.
+
+ <signature of Ty Coon>, 1 April 1989
+ Ty Coon, President of Vice
+
+That's all there is to it!
+
+
+--- The Artistic License 1.0 ---
+
+This software is Copyright (c) 2010 by The "AUTHORS".
+
+This is free software, licensed under:
+
+ The Artistic License 1.0
+
+The Artistic License
+
+Preamble
+
+The intent of this document is to state the conditions under which a Package
+may be copied, such that the Copyright Holder maintains some semblance of
+artistic control over the development of the package, while giving the users of
+the package the right to use and distribute the Package in a more-or-less
+customary fashion, plus the right to make reasonable modifications.
+
+Definitions:
+
+ - "Package" refers to the collection of files distributed by the Copyright
+ Holder, and derivatives of that collection of files created through
+ textual modification.
+ - "Standard Version" refers to such a Package if it has not been modified,
+ or has been modified in accordance with the wishes of the Copyright
+ Holder.
+ - "Copyright Holder" is whoever is named in the copyright or copyrights for
+ the package.
+ - "You" is you, if you're thinking about copying or distributing this Package.
+ - "Reasonable copying fee" is whatever you can justify on the basis of media
+ cost, duplication charges, time of people involved, and so on. (You will
+ not be required to justify it to the Copyright Holder, but only to the
+ computing community at large as a market that must bear the fee.)
+ - "Freely Available" means that no fee is charged for the item itself, though
+ there may be fees involved in handling the item. It also means that
+ recipients of the item may redistribute it under the same conditions they
+ received it.
+
+1. You may make and give away verbatim copies of the source form of the
+Standard Version of this Package without restriction, provided that you
+duplicate all of the original copyright notices and associated disclaimers.
+
+2. You may apply bug fixes, portability fixes and other modifications derived
+from the Public Domain or from the Copyright Holder. A Package modified in such
+a way shall still be considered the Standard Version.
+
+3. You may otherwise modify your copy of this Package in any way, provided that
+you insert a prominent notice in each changed file stating how and when you
+changed that file, and provided that you do at least ONE of the following:
+
+ a) place your modifications in the Public Domain or otherwise make them
+ Freely Available, such as by posting said modifications to Usenet or an
+ equivalent medium, or placing the modifications on a major archive site
+ such as ftp.uu.net, or by allowing the Copyright Holder to include your
+ modifications in the Standard Version of the Package.
+
+ b) use the modified Package only within your corporation or organization.
+
+ c) rename any non-standard executables so the names do not conflict with
+ standard executables, which must also be provided, and provide a separate
+ manual page for each non-standard executable that clearly documents how it
+ differs from the Standard Version.
+
+ d) make other distribution arrangements with the Copyright Holder.
+
+4. You may distribute the programs of this Package in object code or executable
+form, provided that you do at least ONE of the following:
+
+ a) distribute a Standard Version of the executables and library files,
+ together with instructions (in the manual page or equivalent) on where to
+ get the Standard Version.
+
+ b) accompany the distribution with the machine-readable source of the Package
+ with your modifications.
+
+ c) accompany any non-standard executables with their corresponding Standard
+ Version executables, giving the non-standard executables non-standard
+ names, and clearly documenting the differences in manual pages (or
+ equivalent), together with instructions on where to get the Standard
+ Version.
+
+ d) make other distribution arrangements with the Copyright Holder.
+
+5. You may charge a reasonable copying fee for any distribution of this
+Package. You may charge any fee you choose for support of this Package. You
+may not charge a fee for this Package itself. However, you may distribute this
+Package in aggregate with other (possibly commercial) programs as part of a
+larger (possibly commercial) software distribution provided that you do not
+advertise this Package as a product of your own.
+
+6. The scripts and library files supplied as input to or produced as output
+from the programs of this Package do not automatically fall under the copyright
+of this Package, but belong to whomever generated them, and may be sold
+commercially, and may be aggregated with this Package.
+
+7. C or perl subroutines supplied by you and linked into this Package shall not
+be considered part of this Package.
+
+8. The name of the Copyright Holder may not be used to endorse or promote
+products derived from this software without specific prior written permission.
+
+9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
+WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
+MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+
+The End
+
@@ -1,36 +1,87 @@
Changes
-inc/Module/AutoInstall.pm
-inc/Module/Install.pm
-inc/Module/Install/AutoInstall.pm
-inc/Module/Install/Base.pm
-inc/Module/Install/Can.pm
-inc/Module/Install/Fetch.pm
-inc/Module/Install/Include.pm
-inc/Module/Install/Makefile.pm
-inc/Module/Install/Metadata.pm
-inc/Module/Install/Win32.pm
-inc/Module/Install/WriteAll.pm
+LICENSE
+MANIFEST
+META.json
+META.yml
+Makefile.PL
+README
+dist.ini
lib/Catalyst/Engine/Apache.pm
lib/Catalyst/Engine/Apache/MP13.pm
lib/Catalyst/Engine/Apache2.pm
lib/Catalyst/Engine/Apache2/MP19.pm
lib/Catalyst/Engine/Apache2/MP20.pm
-Makefile.PL
-MANIFEST This list of files
-META.yml
-README
-t/02pod.t
-t/03podcoverage.t
+t/00compiles.t
+t/author-live_component_controller_action_action.t
+t/author-live_component_controller_action_auto.t
+t/author-live_component_controller_action_begin.t
+t/author-live_component_controller_action_chained.t
+t/author-live_component_controller_action_default.t
+t/author-live_component_controller_action_detach.t
+t/author-live_component_controller_action_end.t
+t/author-live_component_controller_action_forward.t
+t/author-live_component_controller_action_global.t
+t/author-live_component_controller_action_index.t
+t/author-live_component_controller_action_inheritance.t
+t/author-live_component_controller_action_local.t
+t/author-live_component_controller_action_multipath.t
+t/author-live_component_controller_action_path.t
+t/author-live_component_controller_action_private.t
+t/author-live_component_controller_action_regexp.t
+t/author-live_component_controller_action_streaming.t
+t/author-live_component_controller_args.t
+t/author-live_engine_request_body.t
+t/author-live_engine_request_body_demand.t
+t/author-live_engine_request_cookies.t
+t/author-live_engine_request_headers.t
+t/author-live_engine_request_parameters.t
+t/author-live_engine_request_uploads.t
+t/author-live_engine_request_uri.t
+t/author-live_engine_response_cookies.t
+t/author-live_engine_response_errors.t
+t/author-live_engine_response_headers.t
+t/author-live_engine_response_large.t
+t/author-live_engine_response_redirect.t
+t/author-live_engine_response_status.t
+t/author-live_engine_setup_basics.t
+t/author-live_engine_setup_plugins.t
+t/author-live_fork.t
+t/author-live_loop.t
+t/author-live_plugin_loaded.t
+t/author-live_priorities.t
+t/author-live_recursion.t
+t/author-notabs.t
+t/author-pod.t
+t/author-podcoverage.t
t/catalyst_130pix.gif
t/conf/extra.conf.in
+t/lib/ACLTestApp.pm
+t/lib/ACLTestApp/Controller/Root.pm
+t/lib/CDICompatTestPlugin.pm
t/lib/Catalyst/Action/TestAfter.pm
t/lib/Catalyst/Action/TestBefore.pm
+t/lib/Catalyst/Plugin/Test/Deprecated.pm
t/lib/Catalyst/Plugin/Test/Errors.pm
t/lib/Catalyst/Plugin/Test/Headers.pm
+t/lib/Catalyst/Plugin/Test/MangleDollarUnderScore.pm
t/lib/Catalyst/Plugin/Test/Plugin.pm
+t/lib/Catalyst/Script/Bar.pm
+t/lib/Catalyst/Script/Baz.pm
+t/lib/Catalyst/Script/CompileTest.pm
+t/lib/ChainedActionsApp.pm
+t/lib/ChainedActionsApp/Controller/Root.pm
+t/lib/DeprecatedActionsInAppClassTestApp.pm
+t/lib/DeprecatedTestApp.pm
+t/lib/DeprecatedTestApp/C/Root.pm
+t/lib/NullPackage.pm
t/lib/PluginTestApp.pm
+t/lib/PluginTestApp/Controller/Root.pm
+t/lib/ScriptTestApp/Script/Bar.pm
+t/lib/ScriptTestApp/Script/CompileTest.pm
+t/lib/ScriptTestApp/Script/Foo.pm
t/lib/TestApp.pm
t/lib/TestApp/Action/TestBefore.pm
+t/lib/TestApp/Action/TestExtraArgsAction.pm
t/lib/TestApp/Action/TestMyAction.pm
t/lib/TestApp/Controller/Action.pm
t/lib/TestApp/Controller/Action/Action.pm
@@ -40,21 +91,27 @@ t/lib/TestApp/Controller/Action/Auto/Deep.pm
t/lib/TestApp/Controller/Action/Auto/Default.pm
t/lib/TestApp/Controller/Action/Begin.pm
t/lib/TestApp/Controller/Action/Chained.pm
+t/lib/TestApp/Controller/Action/Chained/ArgsOrder.pm
t/lib/TestApp/Controller/Action/Chained/Auto.pm
t/lib/TestApp/Controller/Action/Chained/Auto/Bar.pm
t/lib/TestApp/Controller/Action/Chained/Auto/Detach.pm
t/lib/TestApp/Controller/Action/Chained/Auto/Foo.pm
t/lib/TestApp/Controller/Action/Chained/Auto/Forward.pm
t/lib/TestApp/Controller/Action/Chained/Bar.pm
+t/lib/TestApp/Controller/Action/Chained/CaptureArgs.pm
t/lib/TestApp/Controller/Action/Chained/Foo.pm
t/lib/TestApp/Controller/Action/Chained/ParentChain.pm
+t/lib/TestApp/Controller/Action/Chained/ParentChain/Relative.pm
t/lib/TestApp/Controller/Action/Chained/PassedArgs.pm
+t/lib/TestApp/Controller/Action/Chained/PathPrefix.pm
t/lib/TestApp/Controller/Action/Chained/Root.pm
t/lib/TestApp/Controller/Action/Default.pm
t/lib/TestApp/Controller/Action/Detach.pm
t/lib/TestApp/Controller/Action/End.pm
t/lib/TestApp/Controller/Action/Forward.pm
+t/lib/TestApp/Controller/Action/ForwardTo.pm
t/lib/TestApp/Controller/Action/Global.pm
+t/lib/TestApp/Controller/Action/Go.pm
t/lib/TestApp/Controller/Action/Index.pm
t/lib/TestApp/Controller/Action/Inheritance.pm
t/lib/TestApp/Controller/Action/Local.pm
@@ -64,74 +121,97 @@ t/lib/TestApp/Controller/Action/Regexp.pm
t/lib/TestApp/Controller/Action/Streaming.pm
t/lib/TestApp/Controller/Action/TestMultipath.pm
t/lib/TestApp/Controller/Action/TestRelative.pm
+t/lib/TestApp/Controller/Action/Visit.pm
+t/lib/TestApp/Controller/Anon.pm
t/lib/TestApp/Controller/Args.pm
+t/lib/TestApp/Controller/Attributes.pm
+t/lib/TestApp/Controller/ContextClosure.pm
t/lib/TestApp/Controller/Dump.pm
-t/lib/TestApp/Controller/Engine/Request/Uploads.pm
t/lib/TestApp/Controller/Engine/Request/URI.pm
+t/lib/TestApp/Controller/Engine/Request/Uploads.pm
t/lib/TestApp/Controller/Engine/Response/Cookies.pm
t/lib/TestApp/Controller/Engine/Response/Errors.pm
t/lib/TestApp/Controller/Engine/Response/Headers.pm
t/lib/TestApp/Controller/Engine/Response/Large.pm
+t/lib/TestApp/Controller/Engine/Response/Print.pm
t/lib/TestApp/Controller/Engine/Response/Redirect.pm
t/lib/TestApp/Controller/Engine/Response/Status.pm
t/lib/TestApp/Controller/Fork.pm
+t/lib/TestApp/Controller/Immutable.pm
+t/lib/TestApp/Controller/Immutable/HardToReload.pm
t/lib/TestApp/Controller/Index.pm
+t/lib/TestApp/Controller/Keyword.pm
+t/lib/TestApp/Controller/Moose.pm
+t/lib/TestApp/Controller/Moose/MethodModifiers.pm
+t/lib/TestApp/Controller/Moose/NoAttributes.pm
t/lib/TestApp/Controller/Priorities.pm
+t/lib/TestApp/Controller/Priorities/MultiMethod.pm
t/lib/TestApp/Controller/Priorities/loc_vs_index.pm
t/lib/TestApp/Controller/Priorities/locre_vs_index.pm
-t/lib/TestApp/Controller/Priorities/MultiMethod.pm
t/lib/TestApp/Controller/Priorities/path_vs_index.pm
t/lib/TestApp/Controller/Priorities/re_vs_index.pm
t/lib/TestApp/Controller/Root.pm
+t/lib/TestApp/DispatchType/CustomPostLoad.pm
+t/lib/TestApp/DispatchType/CustomPreLoad.pm
+t/lib/TestApp/Model.pm
+t/lib/TestApp/Model/ClosuresInConfig.pm
t/lib/TestApp/Model/Foo.pm
t/lib/TestApp/Model/Foo/Bar.pm
+t/lib/TestApp/Model/Generating.pm
+t/lib/TestApp/Plugin/AddDispatchTypes.pm
t/lib/TestApp/Plugin/FullyQualified.pm
+t/lib/TestApp/Plugin/ParameterizedRole.pm
+t/lib/TestApp/RequestBaseBug.pm
+t/lib/TestApp/Role.pm
t/lib/TestApp/View/Dump.pm
-t/lib/TestApp/View/Dump/Parameters.pm
+t/lib/TestApp/View/Dump/Body.pm
+t/lib/TestApp/View/Dump/Env.pm
t/lib/TestApp/View/Dump/Request.pm
t/lib/TestApp/View/Dump/Response.pm
+t/lib/TestAppBadlyImmutable.pm
t/lib/TestAppChainedAbsolutePathPart.pm
t/lib/TestAppChainedAbsolutePathPart/Controller/Foo.pm
t/lib/TestAppChainedRecursive.pm
t/lib/TestAppChainedRecursive/Controller/Foo.pm
+t/lib/TestAppClassExceptionSimpleTest.pm
t/lib/TestAppDoubleAutoBug.pm
-t/live_component_controller_action_action.t
-t/live_component_controller_action_auto.t
-t/live_component_controller_action_begin.t
-t/live_component_controller_action_chained.t
-t/live_component_controller_action_default.t
-t/live_component_controller_action_detach.t
-t/live_component_controller_action_end.t
-t/live_component_controller_action_forward.t
-t/live_component_controller_action_global.t
-t/live_component_controller_action_index.t
-t/live_component_controller_action_inheritance.t
-t/live_component_controller_action_local.t
-t/live_component_controller_action_multipath.t
-t/live_component_controller_action_path.t
-t/live_component_controller_action_private.t
-t/live_component_controller_action_regexp.t
-t/live_component_controller_action_streaming.t
-t/live_component_controller_args.t
-t/live_engine_request_body.t
-t/live_engine_request_cookies.t
-t/live_engine_request_headers.t
-t/live_engine_request_parameters.t
-t/live_engine_request_uploads.t
-t/live_engine_request_uri.t
-t/live_engine_response_cookies.t
-t/live_engine_response_errors.t
-t/live_engine_response_headers.t
-t/live_engine_response_large.t
-t/live_engine_response_redirect.t
-t/live_engine_response_status.t
-t/live_engine_setup_basics.t
-t/live_engine_setup_plugins.t
-t/live_fork.t
-t/live_loop.t
-t/live_plugin_loaded.t
-t/live_priorities.t
-t/live_recursion.t
+t/lib/TestAppDoubleAutoBug/Controller/Root.pm
+t/lib/TestAppEncoding.pm
+t/lib/TestAppEncoding/Controller/Root.pm
+t/lib/TestAppIndexDefault.pm
+t/lib/TestAppIndexDefault/Controller/Default.pm
+t/lib/TestAppIndexDefault/Controller/IndexChained.pm
+t/lib/TestAppIndexDefault/Controller/IndexPrivate.pm
+t/lib/TestAppIndexDefault/Controller/Root.pm
+t/lib/TestAppMatchSingleArg.pm
+t/lib/TestAppMatchSingleArg/Controller/Root.pm
+t/lib/TestAppMetaCompat.pm
+t/lib/TestAppMetaCompat/Controller/Base.pm
+t/lib/TestAppMetaCompat/Controller/Books.pm
+t/lib/TestAppNonMooseController.pm
+t/lib/TestAppNonMooseController/Controller/Foo.pm
+t/lib/TestAppNonMooseController/ControllerBase.pm
+t/lib/TestAppOnDemand.pm
+t/lib/TestAppOnDemand/Controller/Body.pm
+t/lib/TestAppOneView.pm
+t/lib/TestAppOneView/Controller/Root.pm
+t/lib/TestAppOneView/View/Dummy.pm
+t/lib/TestAppPathBug.pm
+t/lib/TestAppPluginWithConstructor.pm
+t/lib/TestAppPluginWithConstructor/Controller/Root.pm
+t/lib/TestAppShowInternalActions.pm
+t/lib/TestAppShowInternalActions/Controller/Root.pm
+t/lib/TestAppStats.pm
+t/lib/TestAppStats/Controller/Root.pm
+t/lib/TestAppToTestScripts.pm
+t/lib/TestAppUnknownError.pm
+t/lib/TestAppViewWarnings.pm
+t/lib/TestAppViewWarnings/Controller/Root.pm
+t/lib/TestAppWithMeta.pm
+t/lib/TestAppWithMeta/Controller/Root.pm
+t/lib/TestPluginWithConstructor.pm
t/optional/mod_perl-locationmatch.pl
t/optional/mod_perl-non-root.pl
t/optional/mod_perl.pl
+t/release-no-tabs.t
+t/release-pod-syntax.t
@@ -0,0 +1,199 @@
+{
+ "abstract" : "Catalyst Apache Engines",
+ "author" : [
+ "Sebastian Riedel <sri@cpan.org>",
+ "Christian Hansen <ch@ngmedia.com>",
+ "Andy Grundman <andy@hybridized.org>",
+ "Tomas Doran <bobtfish@bobtfish.net>"
+ ],
+ "dynamic_config" : 0,
+ "generated_by" : "Dist::Zilla version 4.102341, CPAN::Meta::Converter version 2.102400",
+ "license" : [
+ "perl_5"
+ ],
+ "meta-spec" : {
+ "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
+ "version" : "2"
+ },
+ "name" : "Catalyst-Engine-Apache",
+ "prereqs" : {
+ "configure" : {
+ "requires" : {
+ "ExtUtils::MakeMaker" : "6.31"
+ }
+ },
+ "runtime" : {
+ "requires" : {
+ "Catalyst::Runtime" : "5.80"
+ }
+ }
+ },
+ "release_status" : "stable",
+ "resources" : {
+ "bugtracker" : {
+ "mailto" : "bug-Catalyst-Engine-Apache@rt.cpan.org",
+ "web" : "http://rt.cpan.org/Public/Dist/Display.html?Name=Catalyst-Engine-Apache"
+ },
+ "homepage" : "http://search.cpan.org/dist/Catalyst-Engine-Apache",
+ "repository" : {
+ "type" : "svn",
+ "url" : "http://dev.catalyst.perl.org/repos/Catalyst/Catalyst-Engine-Apache/",
+ "web" : "http://dev.catalystframework.org/svnweb/Catalyst/browse/Catalyst-Engine-Apache"
+ }
+ },
+ "version" : "1.16",
+ "x_Dist_Zilla" : {
+ "plugins" : [
+ {
+ "class" : "Dist::Zilla::Plugin::GatherDir",
+ "name" : "@Filter/@Basic/GatherDir",
+ "version" : "4.102341"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::PruneCruft",
+ "name" : "@Filter/@Basic/PruneCruft",
+ "version" : "4.102341"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::ManifestSkip",
+ "name" : "@Filter/@Basic/ManifestSkip",
+ "version" : "4.102341"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::MetaYAML",
+ "name" : "@Filter/@Basic/MetaYAML",
+ "version" : "4.102341"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::License",
+ "name" : "@Filter/@Basic/License",
+ "version" : "4.102341"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::Readme",
+ "name" : "@Filter/@Basic/Readme",
+ "version" : "4.102341"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::ExtraTests",
+ "name" : "@Filter/@Basic/ExtraTests",
+ "version" : "4.102341"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::ExecDir",
+ "name" : "@Filter/@Basic/ExecDir",
+ "version" : "4.102341"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::ShareDir",
+ "name" : "@Filter/@Basic/ShareDir",
+ "version" : "4.102341"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::MakeMaker",
+ "name" : "@Filter/@Basic/MakeMaker",
+ "version" : "4.102341"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::Manifest",
+ "name" : "@Filter/@Basic/Manifest",
+ "version" : "4.102341"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::TestRelease",
+ "name" : "@Filter/@Basic/TestRelease",
+ "version" : "4.102341"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::ConfirmRelease",
+ "name" : "@Filter/@Basic/ConfirmRelease",
+ "version" : "4.102341"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::UploadToCPAN",
+ "name" : "@Filter/@Basic/UploadToCPAN",
+ "version" : "4.102341"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::MetaConfig",
+ "name" : "@Filter/MetaConfig",
+ "version" : "4.102341"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::MetaJSON",
+ "name" : "@Filter/MetaJSON",
+ "version" : "4.102341"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::PkgVersion",
+ "name" : "@Filter/PkgVersion",
+ "version" : "4.102341"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::PodSyntaxTests",
+ "name" : "@Filter/PodSyntaxTests",
+ "version" : "4.102341"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::NoTabsTests",
+ "name" : "@Filter/NoTabsTests",
+ "version" : "0.01"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::MetaResources",
+ "name" : "@Filter/MetaResources",
+ "version" : "4.102341"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::Authority",
+ "name" : "@Filter/Authority",
+ "version" : "1.000"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::PodWeaver",
+ "name" : "@Filter/PodWeaver",
+ "version" : "3.101640"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::Prereqs",
+ "config" : {
+ "Dist::Zilla::Plugin::Prereqs" : {
+ "phase" : "runtime",
+ "type" : "requires"
+ }
+ },
+ "name" : "Prereqs",
+ "version" : "4.102341"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::FinderCode",
+ "name" : ":InstallModules",
+ "version" : "4.102341"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::FinderCode",
+ "name" : ":TestFiles",
+ "version" : "4.102341"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::FinderCode",
+ "name" : ":ExecFiles",
+ "version" : "4.102341"
+ },
+ {
+ "class" : "Dist::Zilla::Plugin::FinderCode",
+ "name" : ":ShareFiles",
+ "version" : "4.102341"
+ }
+ ],
+ "zilla" : {
+ "class" : "Dist::Zilla::Dist::Builder",
+ "config" : {
+ "is_trial" : 0
+ },
+ "version" : "4.102341"
+ }
+ },
+ "x_authority" : "cpan:BOBTFISH"
+}
+
@@ -1,18 +1,144 @@
----
-abstract: Catalyst Apache Engines
-author: Sebastian Riedel, <sri@cpan.org>
-distribution_type: module
-generated_by: Module::Install version 0.65
+---
+abstract: 'Catalyst Apache Engines'
+author:
+ - 'Sebastian Riedel <sri@cpan.org>'
+ - 'Christian Hansen <ch@ngmedia.com>'
+ - 'Andy Grundman <andy@hybridized.org>'
+ - 'Tomas Doran <bobtfish@bobtfish.net>'
+build_requires: {}
+configure_requires:
+ ExtUtils::MakeMaker: 6.31
+dynamic_config: 0
+generated_by: 'Dist::Zilla version 4.102341, CPAN::Meta::Converter version 2.102400'
license: perl
-meta-spec:
- url: http://module-build.sourceforge.net/META-spec-v1.3.html
- version: 1.3
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
name: Catalyst-Engine-Apache
-no_index:
- directory:
- - inc
- - t
-requires:
- Catalyst::Runtime: 0
-tests: t/0*.t
-version: 1.12
+requires:
+ Catalyst::Runtime: 5.80
+resources:
+ bugtracker: http://rt.cpan.org/Public/Dist/Display.html?Name=Catalyst-Engine-Apache
+ homepage: http://search.cpan.org/dist/Catalyst-Engine-Apache
+ repository: http://dev.catalyst.perl.org/repos/Catalyst/Catalyst-Engine-Apache/
+version: 1.16
+x_Dist_Zilla:
+ plugins:
+ -
+ class: Dist::Zilla::Plugin::GatherDir
+ name: '@Filter/@Basic/GatherDir'
+ version: 4.102341
+ -
+ class: Dist::Zilla::Plugin::PruneCruft
+ name: '@Filter/@Basic/PruneCruft'
+ version: 4.102341
+ -
+ class: Dist::Zilla::Plugin::ManifestSkip
+ name: '@Filter/@Basic/ManifestSkip'
+ version: 4.102341
+ -
+ class: Dist::Zilla::Plugin::MetaYAML
+ name: '@Filter/@Basic/MetaYAML'
+ version: 4.102341
+ -
+ class: Dist::Zilla::Plugin::License
+ name: '@Filter/@Basic/License'
+ version: 4.102341
+ -
+ class: Dist::Zilla::Plugin::Readme
+ name: '@Filter/@Basic/Readme'
+ version: 4.102341
+ -
+ class: Dist::Zilla::Plugin::ExtraTests
+ name: '@Filter/@Basic/ExtraTests'
+ version: 4.102341
+ -
+ class: Dist::Zilla::Plugin::ExecDir
+ name: '@Filter/@Basic/ExecDir'
+ version: 4.102341
+ -
+ class: Dist::Zilla::Plugin::ShareDir
+ name: '@Filter/@Basic/ShareDir'
+ version: 4.102341
+ -
+ class: Dist::Zilla::Plugin::MakeMaker
+ name: '@Filter/@Basic/MakeMaker'
+ version: 4.102341
+ -
+ class: Dist::Zilla::Plugin::Manifest
+ name: '@Filter/@Basic/Manifest'
+ version: 4.102341
+ -
+ class: Dist::Zilla::Plugin::TestRelease
+ name: '@Filter/@Basic/TestRelease'
+ version: 4.102341
+ -
+ class: Dist::Zilla::Plugin::ConfirmRelease
+ name: '@Filter/@Basic/ConfirmRelease'
+ version: 4.102341
+ -
+ class: Dist::Zilla::Plugin::UploadToCPAN
+ name: '@Filter/@Basic/UploadToCPAN'
+ version: 4.102341
+ -
+ class: Dist::Zilla::Plugin::MetaConfig
+ name: '@Filter/MetaConfig'
+ version: 4.102341
+ -
+ class: Dist::Zilla::Plugin::MetaJSON
+ name: '@Filter/MetaJSON'
+ version: 4.102341
+ -
+ class: Dist::Zilla::Plugin::PkgVersion
+ name: '@Filter/PkgVersion'
+ version: 4.102341
+ -
+ class: Dist::Zilla::Plugin::PodSyntaxTests
+ name: '@Filter/PodSyntaxTests'
+ version: 4.102341
+ -
+ class: Dist::Zilla::Plugin::NoTabsTests
+ name: '@Filter/NoTabsTests'
+ version: 0.01
+ -
+ class: Dist::Zilla::Plugin::MetaResources
+ name: '@Filter/MetaResources'
+ version: 4.102341
+ -
+ class: Dist::Zilla::Plugin::Authority
+ name: '@Filter/Authority'
+ version: 1.000
+ -
+ class: Dist::Zilla::Plugin::PodWeaver
+ name: '@Filter/PodWeaver'
+ version: 3.101640
+ -
+ class: Dist::Zilla::Plugin::Prereqs
+ config:
+ Dist::Zilla::Plugin::Prereqs:
+ phase: runtime
+ type: requires
+ name: Prereqs
+ version: 4.102341
+ -
+ class: Dist::Zilla::Plugin::FinderCode
+ name: ':InstallModules'
+ version: 4.102341
+ -
+ class: Dist::Zilla::Plugin::FinderCode
+ name: ':TestFiles'
+ version: 4.102341
+ -
+ class: Dist::Zilla::Plugin::FinderCode
+ name: ':ExecFiles'
+ version: 4.102341
+ -
+ class: Dist::Zilla::Plugin::FinderCode
+ name: ':ShareFiles'
+ version: 4.102341
+ zilla:
+ class: Dist::Zilla::Dist::Builder
+ config:
+ is_trial: 0
+ version: 4.102341
+x_authority: cpan:BOBTFISH
@@ -1,11 +1,51 @@
-use inc::Module::Install 0.65;
-name 'Catalyst-Engine-Apache';
-all_from 'lib/Catalyst/Engine/Apache.pm';
+use strict;
+use warnings;
+
+
+
+use ExtUtils::MakeMaker 6.31;
+
+
+
+my %WriteMakefileArgs = (
+ 'ABSTRACT' => 'Catalyst Apache Engines',
+ 'AUTHOR' => 'Sebastian Riedel <sri@cpan.org>, Christian Hansen <ch@ngmedia.com>, Andy Grundman <andy@hybridized.org>, Tomas Doran <bobtfish@bobtfish.net>',
+ 'BUILD_REQUIRES' => {},
+ 'CONFIGURE_REQUIRES' => {
+ 'ExtUtils::MakeMaker' => '6.31'
+ },
+ 'DISTNAME' => 'Catalyst-Engine-Apache',
+ 'EXE_FILES' => [],
+ 'LICENSE' => 'perl',
+ 'NAME' => 'Catalyst::Engine::Apache',
+ 'PREREQ_PM' => {
+ 'Catalyst::Runtime' => '5.80'
+ },
+ 'VERSION' => '1.16',
+ 'test' => {
+ 'TESTS' => 't/*.t'
+ }
+);
+
+
+unless ( eval { ExtUtils::MakeMaker->VERSION(6.56) } ) {
+ my $br = delete $WriteMakefileArgs{BUILD_REQUIRES};
+ my $pp = $WriteMakefileArgs{PREREQ_PM};
+ for my $mod ( keys %$br ) {
+ if ( exists $pp->{$mod} ) {
+ $pp->{$mod} = $br->{$mod} if $br->{$mod} > $pp->{$mod};
+ }
+ else {
+ $pp->{$mod} = $br->{$mod};
+ }
+ }
+}
+
+delete $WriteMakefileArgs{CONFIGURE_REQUIRES}
+ unless eval { ExtUtils::MakeMaker->VERSION(6.52) };
+
+WriteMakefile(%WriteMakefileArgs);
-requires 'Catalyst::Runtime';
-tests 't/0*.t';
-auto_install;
-WriteAll;
@@ -1,58 +1,13 @@
-NAME
- Catalyst::Engine::Apache - Catalyst Apache Engines
-SYNOPSIS
- For example Apache configurations, see the documentation for the engine
- that corresponds to your Apache version.
- "Catalyst::Engine::Apache::MP13" - mod_perl 1.3x
+This archive contains the distribution Catalyst-Engine-Apache,
+version 1.16:
- "Catalyst::Engine::Apache2::MP19" - mod_perl 1.99x
+ Catalyst Apache Engines
- "Catalyst::Engine::Apache2::MP20" - mod_perl 2.x
+This software is copyright (c) 2010 by The "AUTHORS".
-DESCRIPTION
- These classes provide mod_perl support for Catalyst.
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
-METHODS
- $c->engine->apache
- Returns an "Apache", "Apache::RequestRec" or "Apache2::RequestRec"
- object, depending on your mod_perl version. This method is also
- available as $c->apache.
-
- $c->engine->return
- If you need to return something other than OK from the mod_perl handler,
- you may set any other Apache constant in this method. You should only
- use this method if you know what you are doing or bad things may happen!
- For example, to return DECLINED in mod_perl 2:
-
- use Apache2::Const -compile => qw(DECLINED);
- $c->engine->return( Apache2::Const::DECLINED );
-
-OVERLOADED METHODS
- This class overloads some methods from "Catalyst::Engine".
-
- $c->engine->prepare_request($r)
- $c->engine->prepare_connection
- $c->engine->prepare_query_parameters
- $c->engine->prepare_headers
- $c->engine->prepare_path
- $c->engine->read_chunk
- $c->engine->finalize_body
- $c->engine->finalize_headers
- $c->engine->write
-
-SEE ALSO
- Catalyst Catalyst::Engine.
-
-AUTHORS
- Sebastian Riedel, <sri@cpan.org>
-
- Christian Hansen, <ch@ngmedia.com>
-
- Andy Grundman, <andy@hybridized.org>
-
-COPYRIGHT
- This program is free software, you can redistribute it and/or modify it
- under the same terms as Perl itself.
@@ -0,0 +1,20 @@
+name = Catalyst-Engine-Apache
+version = 1.16
+author = Sebastian Riedel <sri@cpan.org>
+author = Christian Hansen <ch@ngmedia.com>
+author = Andy Grundman <andy@hybridized.org>
+author = Tomas Doran <bobtfish@bobtfish.net>
+license = Perl_5
+copyright_holder = The "AUTHORS"
+
+[@Filter]
+-bundle = @FLORA
+-remove = PodCoverageTests
+-remove = EOLTests
+dist = Catalyst-Engine-Apache
+repository_at = catsvn
+authority = cpan:BOBTFISH
+auto_prereqs = 0
+
+[Prereqs]
+Catalyst::Runtime = 5.80
@@ -1,768 +0,0 @@
-#line 1
-package Module::AutoInstall;
-
-use strict;
-use Cwd ();
-use ExtUtils::MakeMaker ();
-
-use vars qw{$VERSION};
-BEGIN {
- $VERSION = '1.03';
-}
-
-# special map on pre-defined feature sets
-my %FeatureMap = (
- '' => 'Core Features', # XXX: deprecated
- '-core' => 'Core Features',
-);
-
-# various lexical flags
-my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS );
-my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly );
-my ( $PostambleActions, $PostambleUsed );
-
-# See if it's a testing or non-interactive session
-_accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN );
-_init();
-
-sub _accept_default {
- $AcceptDefault = shift;
-}
-
-sub missing_modules {
- return @Missing;
-}
-
-sub do_install {
- __PACKAGE__->install(
- [
- $Config
- ? ( UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
- : ()
- ],
- @Missing,
- );
-}
-
-# initialize various flags, and/or perform install
-sub _init {
- foreach my $arg (
- @ARGV,
- split(
- /[\s\t]+/,
- $ENV{PERL_AUTOINSTALL} || $ENV{PERL_EXTUTILS_AUTOINSTALL} || ''
- )
- )
- {
- if ( $arg =~ /^--config=(.*)$/ ) {
- $Config = [ split( ',', $1 ) ];
- }
- elsif ( $arg =~ /^--installdeps=(.*)$/ ) {
- __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) );
- exit 0;
- }
- elsif ( $arg =~ /^--default(?:deps)?$/ ) {
- $AcceptDefault = 1;
- }
- elsif ( $arg =~ /^--check(?:deps)?$/ ) {
- $CheckOnly = 1;
- }
- elsif ( $arg =~ /^--skip(?:deps)?$/ ) {
- $SkipInstall = 1;
- }
- elsif ( $arg =~ /^--test(?:only)?$/ ) {
- $TestOnly = 1;
- }
- }
-}
-
-# overrides MakeMaker's prompt() to automatically accept the default choice
-sub _prompt {
- goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault;
-
- my ( $prompt, $default ) = @_;
- my $y = ( $default =~ /^[Yy]/ );
-
- print $prompt, ' [', ( $y ? 'Y' : 'y' ), '/', ( $y ? 'n' : 'N' ), '] ';
- print "$default\n";
- return $default;
-}
-
-# the workhorse
-sub import {
- my $class = shift;
- my @args = @_ or return;
- my $core_all;
-
- print "*** $class version " . $class->VERSION . "\n";
- print "*** Checking for Perl dependencies...\n";
-
- my $cwd = Cwd::cwd();
-
- $Config = [];
-
- my $maxlen = length(
- (
- sort { length($b) <=> length($a) }
- grep { /^[^\-]/ }
- map {
- ref($_)
- ? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} )
- : ''
- }
- map { +{@args}->{$_} }
- grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} }
- )[0]
- );
-
- while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) {
- my ( @required, @tests, @skiptests );
- my $default = 1;
- my $conflict = 0;
-
- if ( $feature =~ m/^-(\w+)$/ ) {
- my $option = lc($1);
-
- # check for a newer version of myself
- _update_to( $modules, @_ ) and return if $option eq 'version';
-
- # sets CPAN configuration options
- $Config = $modules if $option eq 'config';
-
- # promote every features to core status
- $core_all = ( $modules =~ /^all$/i ) and next
- if $option eq 'core';
-
- next unless $option eq 'core';
- }
-
- print "[" . ( $FeatureMap{ lc($feature) } || $feature ) . "]\n";
-
- $modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' );
-
- unshift @$modules, -default => &{ shift(@$modules) }
- if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward combatability
-
- while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) {
- if ( $mod =~ m/^-(\w+)$/ ) {
- my $option = lc($1);
-
- $default = $arg if ( $option eq 'default' );
- $conflict = $arg if ( $option eq 'conflict' );
- @tests = @{$arg} if ( $option eq 'tests' );
- @skiptests = @{$arg} if ( $option eq 'skiptests' );
-
- next;
- }
-
- printf( "- %-${maxlen}s ...", $mod );
-
- if ( $arg and $arg =~ /^\D/ ) {
- unshift @$modules, $arg;
- $arg = 0;
- }
-
- # XXX: check for conflicts and uninstalls(!) them.
- if (
- defined( my $cur = _version_check( _load($mod), $arg ||= 0 ) ) )
- {
- print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n";
- push @Existing, $mod => $arg;
- $DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
- }
- else {
- print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n";
- push @required, $mod => $arg;
- }
- }
-
- next unless @required;
-
- my $mandatory = ( $feature eq '-core' or $core_all );
-
- if (
- !$SkipInstall
- and (
- $CheckOnly
- or _prompt(
- qq{==> Auto-install the }
- . ( @required / 2 )
- . ( $mandatory ? ' mandatory' : ' optional' )
- . qq{ module(s) from CPAN?},
- $default ? 'y' : 'n',
- ) =~ /^[Yy]/
- )
- )
- {
- push( @Missing, @required );
- $DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
- }
-
- elsif ( !$SkipInstall
- and $default
- and $mandatory
- and
- _prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', )
- =~ /^[Nn]/ )
- {
- push( @Missing, @required );
- $DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
- }
-
- else {
- $DisabledTests{$_} = 1 for map { glob($_) } @tests;
- }
- }
-
- $UnderCPAN = _check_lock(); # check for $UnderCPAN
-
- if ( @Missing and not( $CheckOnly or $UnderCPAN ) ) {
- require Config;
- print
-"*** Dependencies will be installed the next time you type '$Config::Config{make}'.\n";
-
- # make an educated guess of whether we'll need root permission.
- print " (You may need to do that as the 'root' user.)\n"
- if eval '$>';
- }
- print "*** $class configuration finished.\n";
-
- chdir $cwd;
-
- # import to main::
- no strict 'refs';
- *{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
-}
-
-# Check to see if we are currently running under CPAN.pm and/or CPANPLUS;
-# if we are, then we simply let it taking care of our dependencies
-sub _check_lock {
- return unless @Missing;
-
- if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) {
- print <<'END_MESSAGE';
-
-*** Since we're running under CPANPLUS, I'll just let it take care
- of the dependency's installation later.
-END_MESSAGE
- return 1;
- }
-
- _load_cpan();
-
- # Find the CPAN lock-file
- my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" );
- return unless -f $lock;
-
- # Check the lock
- local *LOCK;
- return unless open(LOCK, $lock);
-
- if (
- ( $^O eq 'MSWin32' ? _under_cpan() : <LOCK> == getppid() )
- and ( $CPAN::Config->{prerequisites_policy} || '' ) ne 'ignore'
- ) {
- print <<'END_MESSAGE';
-
-*** Since we're running under CPAN, I'll just let it take care
- of the dependency's installation later.
-END_MESSAGE
- return 1;
- }
-
- close LOCK;
- return;
-}
-
-sub install {
- my $class = shift;
-
- my $i; # used below to strip leading '-' from config keys
- my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } );
-
- my ( @modules, @installed );
- while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) {
-
- # grep out those already installed
- if ( defined( _version_check( _load($pkg), $ver ) ) ) {
- push @installed, $pkg;
- }
- else {
- push @modules, $pkg, $ver;
- }
- }
-
- return @installed unless @modules; # nothing to do
- return @installed if _check_lock(); # defer to the CPAN shell
-
- print "*** Installing dependencies...\n";
-
- return unless _connected_to('cpan.org');
-
- my %args = @config;
- my %failed;
- local *FAILED;
- if ( $args{do_once} and open( FAILED, '.#autoinstall.failed' ) ) {
- while (<FAILED>) { chomp; $failed{$_}++ }
- close FAILED;
-
- my @newmod;
- while ( my ( $k, $v ) = splice( @modules, 0, 2 ) ) {
- push @newmod, ( $k => $v ) unless $failed{$k};
- }
- @modules = @newmod;
- }
-
- if ( _has_cpanplus() ) {
- _install_cpanplus( \@modules, \@config );
- } else {
- _install_cpan( \@modules, \@config );
- }
-
- print "*** $class installation finished.\n";
-
- # see if we have successfully installed them
- while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
- if ( defined( _version_check( _load($pkg), $ver ) ) ) {
- push @installed, $pkg;
- }
- elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) {
- print FAILED "$pkg\n";
- }
- }
-
- close FAILED if $args{do_once};
-
- return @installed;
-}
-
-sub _install_cpanplus {
- my @modules = @{ +shift };
- my @config = _cpanplus_config( @{ +shift } );
- my $installed = 0;
-
- require CPANPLUS::Backend;
- my $cp = CPANPLUS::Backend->new;
- my $conf = $cp->configure_object;
-
- return unless $conf->can('conf') # 0.05x+ with "sudo" support
- or _can_write($conf->_get_build('base')); # 0.04x
-
- # if we're root, set UNINST=1 to avoid trouble unless user asked for it.
- my $makeflags = $conf->get_conf('makeflags') || '';
- if ( UNIVERSAL::isa( $makeflags, 'HASH' ) ) {
- # 0.03+ uses a hashref here
- $makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST};
-
- } else {
- # 0.02 and below uses a scalar
- $makeflags = join( ' ', split( ' ', $makeflags ), 'UNINST=1' )
- if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } );
-
- }
- $conf->set_conf( makeflags => $makeflags );
- $conf->set_conf( prereqs => 1 );
-
-
-
- while ( my ( $key, $val ) = splice( @config, 0, 2 ) ) {
- $conf->set_conf( $key, $val );
- }
-
- my $modtree = $cp->module_tree;
- while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
- print "*** Installing $pkg...\n";
-
- MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall;
-
- my $success;
- my $obj = $modtree->{$pkg};
-
- if ( $obj and defined( _version_check( $obj->{version}, $ver ) ) ) {
- my $pathname = $pkg;
- $pathname =~ s/::/\\W/;
-
- foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) {
- delete $INC{$inc};
- }
-
- my $rv = $cp->install( modules => [ $obj->{module} ] );
-
- if ( $rv and ( $rv->{ $obj->{module} } or $rv->{ok} ) ) {
- print "*** $pkg successfully installed.\n";
- $success = 1;
- } else {
- print "*** $pkg installation cancelled.\n";
- $success = 0;
- }
-
- $installed += $success;
- } else {
- print << ".";
-*** Could not find a version $ver or above for $pkg; skipping.
-.
- }
-
- MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall;
- }
-
- return $installed;
-}
-
-sub _cpanplus_config {
- my @config = ();
- while ( @_ ) {
- my ($key, $value) = (shift(), shift());
- if ( $key eq 'prerequisites_policy' ) {
- if ( $value eq 'follow' ) {
- $value = CPANPLUS::Internals::Constants::PREREQ_INSTALL();
- } elsif ( $value eq 'ask' ) {
- $value = CPANPLUS::Internals::Constants::PREREQ_ASK();
- } elsif ( $value eq 'ignore' ) {
- $value = CPANPLUS::Internals::Constants::PREREQ_IGNORE();
- } else {
- die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n";
- }
- } else {
- die "*** Cannot convert option $key to CPANPLUS version.\n";
- }
- }
- return @config;
-}
-
-sub _install_cpan {
- my @modules = @{ +shift };
- my @config = @{ +shift };
- my $installed = 0;
- my %args;
-
- _load_cpan();
- require Config;
-
- if (CPAN->VERSION < 1.80) {
- # no "sudo" support, probe for writableness
- return unless _can_write( MM->catfile( $CPAN::Config->{cpan_home}, 'sources' ) )
- and _can_write( $Config::Config{sitelib} );
- }
-
- # if we're root, set UNINST=1 to avoid trouble unless user asked for it.
- my $makeflags = $CPAN::Config->{make_install_arg} || '';
- $CPAN::Config->{make_install_arg} =
- join( ' ', split( ' ', $makeflags ), 'UNINST=1' )
- if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } );
-
- # don't show start-up info
- $CPAN::Config->{inhibit_startup_message} = 1;
-
- # set additional options
- while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) {
- ( $args{$opt} = $arg, next )
- if $opt =~ /^force$/; # pseudo-option
- $CPAN::Config->{$opt} = $arg;
- }
-
- local $CPAN::Config->{prerequisites_policy} = 'follow';
-
- while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
- MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall;
-
- print "*** Installing $pkg...\n";
-
- my $obj = CPAN::Shell->expand( Module => $pkg );
- my $success = 0;
-
- if ( $obj and defined( _version_check( $obj->cpan_version, $ver ) ) ) {
- my $pathname = $pkg;
- $pathname =~ s/::/\\W/;
-
- foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) {
- delete $INC{$inc};
- }
-
- my $rv = $args{force} ? CPAN::Shell->force( install => $pkg )
- : CPAN::Shell->install($pkg);
- $rv ||= eval {
- $CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, )
- ->{install}
- if $CPAN::META;
- };
-
- if ( $rv eq 'YES' ) {
- print "*** $pkg successfully installed.\n";
- $success = 1;
- }
- else {
- print "*** $pkg installation failed.\n";
- $success = 0;
- }
-
- $installed += $success;
- }
- else {
- print << ".";
-*** Could not find a version $ver or above for $pkg; skipping.
-.
- }
-
- MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall;
- }
-
- return $installed;
-}
-
-sub _has_cpanplus {
- return (
- $HasCPANPLUS = (
- $INC{'CPANPLUS/Config.pm'}
- or _load('CPANPLUS::Shell::Default')
- )
- );
-}
-
-# make guesses on whether we're under the CPAN installation directory
-sub _under_cpan {
- require Cwd;
- require File::Spec;
-
- my $cwd = File::Spec->canonpath( Cwd::cwd() );
- my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} );
-
- return ( index( $cwd, $cpan ) > -1 );
-}
-
-sub _update_to {
- my $class = __PACKAGE__;
- my $ver = shift;
-
- return
- if defined( _version_check( _load($class), $ver ) ); # no need to upgrade
-
- if (
- _prompt( "==> A newer version of $class ($ver) is required. Install?",
- 'y' ) =~ /^[Nn]/
- )
- {
- die "*** Please install $class $ver manually.\n";
- }
-
- print << ".";
-*** Trying to fetch it from CPAN...
-.
-
- # install ourselves
- _load($class) and return $class->import(@_)
- if $class->install( [], $class, $ver );
-
- print << '.'; exit 1;
-
-*** Cannot bootstrap myself. :-( Installation terminated.
-.
-}
-
-# check if we're connected to some host, using inet_aton
-sub _connected_to {
- my $site = shift;
-
- return (
- ( _load('Socket') and Socket::inet_aton($site) ) or _prompt(
- qq(
-*** Your host cannot resolve the domain name '$site', which
- probably means the Internet connections are unavailable.
-==> Should we try to install the required module(s) anyway?), 'n'
- ) =~ /^[Yy]/
- );
-}
-
-# check if a directory is writable; may create it on demand
-sub _can_write {
- my $path = shift;
- mkdir( $path, 0755 ) unless -e $path;
-
- return 1 if -w $path;
-
- print << ".";
-*** You are not allowed to write to the directory '$path';
- the installation may fail due to insufficient permissions.
-.
-
- if (
- eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt(
- qq(
-==> Should we try to re-execute the autoinstall process with 'sudo'?),
- ((-t STDIN) ? 'y' : 'n')
- ) =~ /^[Yy]/
- )
- {
-
- # try to bootstrap ourselves from sudo
- print << ".";
-*** Trying to re-execute the autoinstall process with 'sudo'...
-.
- my $missing = join( ',', @Missing );
- my $config = join( ',',
- UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
- if $Config;
-
- return
- unless system( 'sudo', $^X, $0, "--config=$config",
- "--installdeps=$missing" );
-
- print << ".";
-*** The 'sudo' command exited with error! Resuming...
-.
- }
-
- return _prompt(
- qq(
-==> Should we try to install the required module(s) anyway?), 'n'
- ) =~ /^[Yy]/;
-}
-
-# load a module and return the version it reports
-sub _load {
- my $mod = pop; # class/instance doesn't matter
- my $file = $mod;
-
- $file =~ s|::|/|g;
- $file .= '.pm';
-
- local $@;
- return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 );
-}
-
-# Load CPAN.pm and it's configuration
-sub _load_cpan {
- return if $CPAN::VERSION;
- require CPAN;
- if ( $CPAN::HandleConfig::VERSION ) {
- # Newer versions of CPAN have a HandleConfig module
- CPAN::HandleConfig->load;
- } else {
- # Older versions had the load method in Config directly
- CPAN::Config->load;
- }
-}
-
-# compare two versions, either use Sort::Versions or plain comparison
-sub _version_check {
- my ( $cur, $min ) = @_;
- return unless defined $cur;
-
- $cur =~ s/\s+$//;
-
- # check for version numbers that are not in decimal format
- if ( ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./ ) {
- if ( ( $version::VERSION or defined( _load('version') )) and
- version->can('new')
- ) {
-
- # use version.pm if it is installed.
- return (
- ( version->new($cur) >= version->new($min) ) ? $cur : undef );
- }
- elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) )
- {
-
- # use Sort::Versions as the sorting algorithm for a.b.c versions
- return ( ( Sort::Versions::versioncmp( $cur, $min ) != -1 )
- ? $cur
- : undef );
- }
-
- warn "Cannot reliably compare non-decimal formatted versions.\n"
- . "Please install version.pm or Sort::Versions.\n";
- }
-
- # plain comparison
- local $^W = 0; # shuts off 'not numeric' bugs
- return ( $cur >= $min ? $cur : undef );
-}
-
-# nothing; this usage is deprecated.
-sub main::PREREQ_PM { return {}; }
-
-sub _make_args {
- my %args = @_;
-
- $args{PREREQ_PM} = { %{ $args{PREREQ_PM} || {} }, @Existing, @Missing }
- if $UnderCPAN or $TestOnly;
-
- if ( $args{EXE_FILES} and -e 'MANIFEST' ) {
- require ExtUtils::Manifest;
- my $manifest = ExtUtils::Manifest::maniread('MANIFEST');
-
- $args{EXE_FILES} =
- [ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ];
- }
-
- $args{test}{TESTS} ||= 't/*.t';
- $args{test}{TESTS} = join( ' ',
- grep { !exists( $DisabledTests{$_} ) }
- map { glob($_) } split( /\s+/, $args{test}{TESTS} ) );
-
- my $missing = join( ',', @Missing );
- my $config =
- join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
- if $Config;
-
- $PostambleActions = (
- $missing
- ? "\$(PERL) $0 --config=$config --installdeps=$missing"
- : "\$(NOECHO) \$(NOOP)"
- );
-
- return %args;
-}
-
-# a wrapper to ExtUtils::MakeMaker::WriteMakefile
-sub Write {
- require Carp;
- Carp::croak "WriteMakefile: Need even number of args" if @_ % 2;
-
- if ($CheckOnly) {
- print << ".";
-*** Makefile not written in check-only mode.
-.
- return;
- }
-
- my %args = _make_args(@_);
-
- no strict 'refs';
-
- $PostambleUsed = 0;
- local *MY::postamble = \&postamble unless defined &MY::postamble;
- ExtUtils::MakeMaker::WriteMakefile(%args);
-
- print << "." unless $PostambleUsed;
-*** WARNING: Makefile written with customized MY::postamble() without
- including contents from Module::AutoInstall::postamble() --
- auto installation features disabled. Please contact the author.
-.
-
- return 1;
-}
-
-sub postamble {
- $PostambleUsed = 1;
-
- return << ".";
-
-config :: installdeps
-\t\$(NOECHO) \$(NOOP)
-
-checkdeps ::
-\t\$(PERL) $0 --checkdeps
-
-installdeps ::
-\t$PostambleActions
-
-.
-
-}
-
-1;
-
-__END__
-
-#line 1003
@@ -1,61 +0,0 @@
-#line 1
-package Module::Install::AutoInstall;
-
-use strict;
-use Module::Install::Base;
-
-use vars qw{$VERSION $ISCORE @ISA};
-BEGIN {
- $VERSION = '0.65';
- $ISCORE = 1;
- @ISA = qw{Module::Install::Base};
-}
-
-sub AutoInstall { $_[0] }
-
-sub run {
- my $self = shift;
- $self->auto_install_now(@_);
-}
-
-sub write {
- my $self = shift;
- $self->auto_install(@_);
-}
-
-sub auto_install {
- my $self = shift;
- return if $self->{done}++;
-
- # Flatten array of arrays into a single array
- my @core = map @$_, map @$_, grep ref,
- $self->build_requires, $self->requires;
-
- my @config = @_;
-
- # We'll need Module::AutoInstall
- $self->include('Module::AutoInstall');
- require Module::AutoInstall;
-
- Module::AutoInstall->import(
- (@config ? (-config => \@config) : ()),
- (@core ? (-core => \@core) : ()),
- $self->features,
- );
-
- $self->makemaker_args( Module::AutoInstall::_make_args() );
-
- my $class = ref($self);
- $self->postamble(
- "# --- $class section:\n" .
- Module::AutoInstall::postamble()
- );
-}
-
-sub auto_install_now {
- my $self = shift;
- $self->auto_install(@_);
- Module::AutoInstall::do_install();
-}
-
-1;
@@ -1,70 +0,0 @@
-#line 1
-package Module::Install::Base;
-
-$VERSION = '0.65';
-
-# Suspend handler for "redefined" warnings
-BEGIN {
- my $w = $SIG{__WARN__};
- $SIG{__WARN__} = sub { $w };
-}
-
-### This is the ONLY module that shouldn't have strict on
-# use strict;
-
-#line 41
-
-sub new {
- my ($class, %args) = @_;
-
- foreach my $method ( qw(call load) ) {
- *{"$class\::$method"} = sub {
- shift()->_top->$method(@_);
- } unless defined &{"$class\::$method"};
- }
-
- bless( \%args, $class );
-}
-
-#line 61
-
-sub AUTOLOAD {
- my $self = shift;
- local $@;
- my $autoload = eval { $self->_top->autoload } or return;
- goto &$autoload;
-}
-
-#line 76
-
-sub _top { $_[0]->{_top} }
-
-#line 89
-
-sub admin {
- $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new;
-}
-
-sub is_admin {
- $_[0]->admin->VERSION;
-}
-
-sub DESTROY {}
-
-package Module::Install::Base::FakeAdmin;
-
-my $Fake;
-sub new { $Fake ||= bless(\@_, $_[0]) }
-
-sub AUTOLOAD {}
-
-sub DESTROY {}
-
-# Restore warning handler
-BEGIN {
- $SIG{__WARN__} = $SIG{__WARN__}->();
-}
-
-1;
-
-#line 138
@@ -1,82 +0,0 @@
-#line 1
-package Module::Install::Can;
-
-use strict;
-use Module::Install::Base;
-use Config ();
-### This adds a 5.005 Perl version dependency.
-### This is a bug and will be fixed.
-use File::Spec ();
-use ExtUtils::MakeMaker ();
-
-use vars qw{$VERSION $ISCORE @ISA};
-BEGIN {
- $VERSION = '0.65';
- $ISCORE = 1;
- @ISA = qw{Module::Install::Base};
-}
-
-# check if we can load some module
-### Upgrade this to not have to load the module if possible
-sub can_use {
- my ($self, $mod, $ver) = @_;
- $mod =~ s{::|\\}{/}g;
- $mod .= '.pm' unless $mod =~ /\.pm$/i;
-
- my $pkg = $mod;
- $pkg =~ s{/}{::}g;
- $pkg =~ s{\.pm$}{}i;
-
- local $@;
- eval { require $mod; $pkg->VERSION($ver || 0); 1 };
-}
-
-# check if we can run some command
-sub can_run {
- my ($self, $cmd) = @_;
-
- my $_cmd = $cmd;
- return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));
-
- for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
- my $abs = File::Spec->catfile($dir, $_[1]);
- return $abs if (-x $abs or $abs = MM->maybe_command($abs));
- }
-
- return;
-}
-
-# can we locate a (the) C compiler
-sub can_cc {
- my $self = shift;
- my @chunks = split(/ /, $Config::Config{cc}) or return;
-
- # $Config{cc} may contain args; try to find out the program part
- while (@chunks) {
- return $self->can_run("@chunks") || (pop(@chunks), next);
- }
-
- return;
-}
-
-# Fix Cygwin bug on maybe_command();
-if ( $^O eq 'cygwin' ) {
- require ExtUtils::MM_Cygwin;
- require ExtUtils::MM_Win32;
- if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) {
- *ExtUtils::MM_Cygwin::maybe_command = sub {
- my ($self, $file) = @_;
- if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) {
- ExtUtils::MM_Win32->maybe_command($file);
- } else {
- ExtUtils::MM_Unix->maybe_command($file);
- }
- }
- }
-}
-
-1;
-
-__END__
-
-#line 157
@@ -1,93 +0,0 @@
-#line 1
-package Module::Install::Fetch;
-
-use strict;
-use Module::Install::Base;
-
-use vars qw{$VERSION $ISCORE @ISA};
-BEGIN {
- $VERSION = '0.65';
- $ISCORE = 1;
- @ISA = qw{Module::Install::Base};
-}
-
-sub get_file {
- my ($self, %args) = @_;
- my ($scheme, $host, $path, $file) =
- $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
-
- if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) {
- $args{url} = $args{ftp_url}
- or (warn("LWP support unavailable!\n"), return);
- ($scheme, $host, $path, $file) =
- $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
- }
-
- $|++;
- print "Fetching '$file' from $host... ";
-
- unless (eval { require Socket; Socket::inet_aton($host) }) {
- warn "'$host' resolve failed!\n";
- return;
- }
-
- return unless $scheme eq 'ftp' or $scheme eq 'http';
-
- require Cwd;
- my $dir = Cwd::getcwd();
- chdir $args{local_dir} or return if exists $args{local_dir};
-
- if (eval { require LWP::Simple; 1 }) {
- LWP::Simple::mirror($args{url}, $file);
- }
- elsif (eval { require Net::FTP; 1 }) { eval {
- # use Net::FTP to get past firewall
- my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600);
- $ftp->login("anonymous", 'anonymous@example.com');
- $ftp->cwd($path);
- $ftp->binary;
- $ftp->get($file) or (warn("$!\n"), return);
- $ftp->quit;
- } }
- elsif (my $ftp = $self->can_run('ftp')) { eval {
- # no Net::FTP, fallback to ftp.exe
- require FileHandle;
- my $fh = FileHandle->new;
-
- local $SIG{CHLD} = 'IGNORE';
- unless ($fh->open("|$ftp -n")) {
- warn "Couldn't open ftp: $!\n";
- chdir $dir; return;
- }
-
- my @dialog = split(/\n/, <<"END_FTP");
-open $host
-user anonymous anonymous\@example.com
-cd $path
-binary
-get $file $file
-quit
-END_FTP
- foreach (@dialog) { $fh->print("$_\n") }
- $fh->close;
- } }
- else {
- warn "No working 'ftp' program available!\n";
- chdir $dir; return;
- }
-
- unless (-f $file) {
- warn "Fetching failed: $@\n";
- chdir $dir; return;
- }
-
- return if exists $args{size} and -s $file != $args{size};
- system($args{run}) if exists $args{run};
- unlink($file) if $args{remove};
-
- print(((!exists $args{check_for} or -e $args{check_for})
- ? "done!" : "failed! ($!)"), "\n");
- chdir $dir; return !$?;
-}
-
-1;
@@ -1,34 +0,0 @@
-#line 1
-package Module::Install::Include;
-
-use strict;
-use Module::Install::Base;
-
-use vars qw{$VERSION $ISCORE @ISA};
-BEGIN {
- $VERSION = '0.65';
- $ISCORE = 1;
- @ISA = qw{Module::Install::Base};
-}
-
-sub include {
- shift()->admin->include(@_);
-}
-
-sub include_deps {
- shift()->admin->include_deps(@_);
-}
-
-sub auto_include {
- shift()->admin->auto_include(@_);
-}
-
-sub auto_include_deps {
- shift()->admin->auto_include_deps(@_);
-}
-
-sub auto_include_dependent_dists {
- shift()->admin->auto_include_dependent_dists(@_);
-}
-
-1;
@@ -1,212 +0,0 @@
-#line 1
-package Module::Install::Makefile;
-
-use strict 'vars';
-use Module::Install::Base;
-use ExtUtils::MakeMaker ();
-
-use vars qw{$VERSION $ISCORE @ISA};
-BEGIN {
- $VERSION = '0.65';
- $ISCORE = 1;
- @ISA = qw{Module::Install::Base};
-}
-
-sub Makefile { $_[0] }
-
-my %seen = ();
-
-sub prompt {
- shift;
-
- # Infinite loop protection
- my @c = caller();
- if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) {
- die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])";
- }
-
- # In automated testing, always use defaults
- if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) {
- local $ENV{PERL_MM_USE_DEFAULT} = 1;
- goto &ExtUtils::MakeMaker::prompt;
- } else {
- goto &ExtUtils::MakeMaker::prompt;
- }
-}
-
-sub makemaker_args {
- my $self = shift;
- my $args = ($self->{makemaker_args} ||= {});
- %$args = ( %$args, @_ ) if @_;
- $args;
-}
-
-# For mm args that take multiple space-seperated args,
-# append an argument to the current list.
-sub makemaker_append {
- my $self = shift;
- my $name = shift;
- my $args = $self->makemaker_args;
- $args->{name} = defined $args->{$name}
- ? join( ' ', $args->{name}, @_ )
- : join( ' ', @_ );
-}
-
-sub build_subdirs {
- my $self = shift;
- my $subdirs = $self->makemaker_args->{DIR} ||= [];
- for my $subdir (@_) {
- push @$subdirs, $subdir;
- }
-}
-
-sub clean_files {
- my $self = shift;
- my $clean = $self->makemaker_args->{clean} ||= {};
- %$clean = (
- %$clean,
- FILES => join(' ', grep length, $clean->{FILES}, @_),
- );
-}
-
-sub realclean_files {
- my $self = shift;
- my $realclean = $self->makemaker_args->{realclean} ||= {};
- %$realclean = (
- %$realclean,
- FILES => join(' ', grep length, $realclean->{FILES}, @_),
- );
-}
-
-sub libs {
- my $self = shift;
- my $libs = ref $_[0] ? shift : [ shift ];
- $self->makemaker_args( LIBS => $libs );
-}
-
-sub inc {
- my $self = shift;
- $self->makemaker_args( INC => shift );
-}
-
-sub write {
- my $self = shift;
- die "&Makefile->write() takes no arguments\n" if @_;
-
- my $args = $self->makemaker_args;
- $args->{DISTNAME} = $self->name;
- $args->{NAME} = $self->module_name || $self->name || $self->determine_NAME($args);
- $args->{VERSION} = $self->version || $self->determine_VERSION($args);
- $args->{NAME} =~ s/-/::/g;
- if ( $self->tests ) {
- $args->{test} = { TESTS => $self->tests };
- }
- if ($] >= 5.005) {
- $args->{ABSTRACT} = $self->abstract;
- $args->{AUTHOR} = $self->author;
- }
- if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) {
- $args->{NO_META} = 1;
- }
- if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) {
- $args->{SIGN} = 1;
- }
- unless ( $self->is_admin ) {
- delete $args->{SIGN};
- }
-
- # merge both kinds of requires into prereq_pm
- my $prereq = ($args->{PREREQ_PM} ||= {});
- %$prereq = ( %$prereq, map { @$_ } map { @$_ } grep $_,
- ($self->build_requires, $self->requires) );
-
- # merge both kinds of requires into prereq_pm
- my $subdirs = ($args->{DIR} ||= []);
- if ($self->bundles) {
- foreach my $bundle (@{ $self->bundles }) {
- my ($file, $dir) = @$bundle;
- push @$subdirs, $dir if -d $dir;
- delete $prereq->{$file};
- }
- }
-
- if ( my $perl_version = $self->perl_version ) {
- eval "use $perl_version; 1"
- or die "ERROR: perl: Version $] is installed, "
- . "but we need version >= $perl_version";
- }
-
- $args->{INSTALLDIRS} = $self->installdirs;
-
- my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args;
-
- my $user_preop = delete $args{dist}->{PREOP};
- if (my $preop = $self->admin->preop($user_preop)) {
- $args{dist} = $preop;
- }
-
- my $mm = ExtUtils::MakeMaker::WriteMakefile(%args);
- $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile');
-}
-
-sub fix_up_makefile {
- my $self = shift;
- my $makefile_name = shift;
- my $top_class = ref($self->_top) || '';
- my $top_version = $self->_top->VERSION || '';
-
- my $preamble = $self->preamble
- ? "# Preamble by $top_class $top_version\n"
- . $self->preamble
- : '';
- my $postamble = "# Postamble by $top_class $top_version\n"
- . ($self->postamble || '');
-
- local *MAKEFILE;
- open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
- my $makefile = do { local $/; <MAKEFILE> };
- close MAKEFILE or die $!;
-
- $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /;
- $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g;
- $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g;
- $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m;
- $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m;
-
- # Module::Install will never be used to build the Core Perl
- # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks
- # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist
- $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m;
- #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
-
- # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
- $makefile =~ s/("?)-I\$\(PERL_LIB\)\1//g;
-
- # XXX - This is currently unused; not sure if it breaks other MM-users
- # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
-
- open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
- print MAKEFILE "$preamble$makefile$postamble" or die $!;
- close MAKEFILE or die $!;
-
- 1;
-}
-
-sub preamble {
- my ($self, $text) = @_;
- $self->{preamble} = $text . $self->{preamble} if defined $text;
- $self->{preamble};
-}
-
-sub postamble {
- my ($self, $text) = @_;
- $self->{postamble} ||= $self->admin->postamble;
- $self->{postamble} .= $text if defined $text;
- $self->{postamble}
-}
-
-1;
-
-__END__
-
-#line 338
@@ -1,323 +0,0 @@
-#line 1
-package Module::Install::Metadata;
-
-use strict 'vars';
-use Module::Install::Base;
-
-use vars qw{$VERSION $ISCORE @ISA};
-BEGIN {
- $VERSION = '0.65';
- $ISCORE = 1;
- @ISA = qw{Module::Install::Base};
-}
-
-my @scalar_keys = qw{
- name module_name abstract author version license
- distribution_type perl_version tests installdirs
-};
-
-my @tuple_keys = qw{
- build_requires requires recommends bundles
-};
-
-sub Meta { shift }
-sub Meta_ScalarKeys { @scalar_keys }
-sub Meta_TupleKeys { @tuple_keys }
-
-foreach my $key (@scalar_keys) {
- *$key = sub {
- my $self = shift;
- return $self->{values}{$key} if defined wantarray and !@_;
- $self->{values}{$key} = shift;
- return $self;
- };
-}
-
-foreach my $key (@tuple_keys) {
- *$key = sub {
- my $self = shift;
- return $self->{values}{$key} unless @_;
-
- my @rv;
- while (@_) {
- my $module = shift or last;
- my $version = shift || 0;
- if ( $module eq 'perl' ) {
- $version =~ s{^(\d+)\.(\d+)\.(\d+)}
- {$1 + $2/1_000 + $3/1_000_000}e;
- $self->perl_version($version);
- next;
- }
- my $rv = [ $module, $version ];
- push @rv, $rv;
- }
- push @{ $self->{values}{$key} }, @rv;
- @rv;
- };
-}
-
-sub install_as_core { $_[0]->installdirs('perl') }
-sub install_as_cpan { $_[0]->installdirs('site') }
-sub install_as_site { $_[0]->installdirs('site') }
-sub install_as_vendor { $_[0]->installdirs('vendor') }
-
-sub sign {
- my $self = shift;
- return $self->{'values'}{'sign'} if defined wantarray and !@_;
- $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
- return $self;
-}
-
-sub dynamic_config {
- my $self = shift;
- unless ( @_ ) {
- warn "You MUST provide an explicit true/false value to dynamic_config, skipping\n";
- return $self;
- }
- $self->{'values'}{'dynamic_config'} = $_[0] ? 1 : 0;
- return $self;
-}
-
-sub all_from {
- my ( $self, $file ) = @_;
-
- unless ( defined($file) ) {
- my $name = $self->name
- or die "all_from called with no args without setting name() first";
- $file = join('/', 'lib', split(/-/, $name)) . '.pm';
- $file =~ s{.*/}{} unless -e $file;
- die "all_from: cannot find $file from $name" unless -e $file;
- }
-
- $self->version_from($file) unless $self->version;
- $self->perl_version_from($file) unless $self->perl_version;
-
- # The remaining probes read from POD sections; if the file
- # has an accompanying .pod, use that instead
- my $pod = $file;
- if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) {
- $file = $pod;
- }
-
- $self->author_from($file) unless $self->author;
- $self->license_from($file) unless $self->license;
- $self->abstract_from($file) unless $self->abstract;
-}
-
-sub provides {
- my $self = shift;
- my $provides = ( $self->{values}{provides} ||= {} );
- %$provides = (%$provides, @_) if @_;
- return $provides;
-}
-
-sub auto_provides {
- my $self = shift;
- return $self unless $self->is_admin;
-
- unless (-e 'MANIFEST') {
- warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
- return $self;
- }
-
- # Avoid spurious warnings as we are not checking manifest here.
-
- local $SIG{__WARN__} = sub {1};
- require ExtUtils::Manifest;
- local *ExtUtils::Manifest::manicheck = sub { return };
-
- require Module::Build;
- my $build = Module::Build->new(
- dist_name => $self->name,
- dist_version => $self->version,
- license => $self->license,
- );
- $self->provides(%{ $build->find_dist_packages || {} });
-}
-
-sub feature {
- my $self = shift;
- my $name = shift;
- my $features = ( $self->{values}{features} ||= [] );
-
- my $mods;
-
- if ( @_ == 1 and ref( $_[0] ) ) {
- # The user used ->feature like ->features by passing in the second
- # argument as a reference. Accomodate for that.
- $mods = $_[0];
- } else {
- $mods = \@_;
- }
-
- my $count = 0;
- push @$features, (
- $name => [
- map {
- ref($_) ? ( ref($_) eq 'HASH' ) ? %$_
- : @$_
- : $_
- } @$mods
- ]
- );
-
- return @$features;
-}
-
-sub features {
- my $self = shift;
- while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
- $self->feature( $name, @$mods );
- }
- return $self->{values}->{features}
- ? @{ $self->{values}->{features} }
- : ();
-}
-
-sub no_index {
- my $self = shift;
- my $type = shift;
- push @{ $self->{values}{no_index}{$type} }, @_ if $type;
- return $self->{values}{no_index};
-}
-
-sub read {
- my $self = shift;
- $self->include_deps( 'YAML', 0 );
-
- require YAML;
- my $data = YAML::LoadFile('META.yml');
-
- # Call methods explicitly in case user has already set some values.
- while ( my ( $key, $value ) = each %$data ) {
- next unless $self->can($key);
- if ( ref $value eq 'HASH' ) {
- while ( my ( $module, $version ) = each %$value ) {
- $self->can($key)->($self, $module => $version );
- }
- }
- else {
- $self->can($key)->($self, $value);
- }
- }
- return $self;
-}
-
-sub write {
- my $self = shift;
- return $self unless $self->is_admin;
- $self->admin->write_meta;
- return $self;
-}
-
-sub version_from {
- my ( $self, $file ) = @_;
- require ExtUtils::MM_Unix;
- $self->version( ExtUtils::MM_Unix->parse_version($file) );
-}
-
-sub abstract_from {
- my ( $self, $file ) = @_;
- require ExtUtils::MM_Unix;
- $self->abstract(
- bless(
- { DISTNAME => $self->name },
- 'ExtUtils::MM_Unix'
- )->parse_abstract($file)
- );
-}
-
-sub _slurp {
- my ( $self, $file ) = @_;
-
- local *FH;
- open FH, "< $file" or die "Cannot open $file.pod: $!";
- do { local $/; <FH> };
-}
-
-sub perl_version_from {
- my ( $self, $file ) = @_;
-
- if (
- $self->_slurp($file) =~ m/
- ^
- use \s*
- v?
- ([\d_\.]+)
- \s* ;
- /ixms
- )
- {
- my $v = $1;
- $v =~ s{_}{}g;
- $self->perl_version($1);
- }
- else {
- warn "Cannot determine perl version info from $file\n";
- return;
- }
-}
-
-sub author_from {
- my ( $self, $file ) = @_;
- my $content = $self->_slurp($file);
- if ($content =~ m/
- =head \d \s+ (?:authors?)\b \s*
- ([^\n]*)
- |
- =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
- .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
- ([^\n]*)
- /ixms) {
- my $author = $1 || $2;
- $author =~ s{E<lt>}{<}g;
- $author =~ s{E<gt>}{>}g;
- $self->author($author);
- }
- else {
- warn "Cannot determine author info from $file\n";
- }
-}
-
-sub license_from {
- my ( $self, $file ) = @_;
-
- if (
- $self->_slurp($file) =~ m/
- (
- =head \d \s+
- (?:licen[cs]e|licensing|copyright|legal)\b
- .*?
- )
- (=head\\d.*|=cut.*|)
- \z
- /ixms
- )
- {
- my $license_text = $1;
- my @phrases = (
- 'under the same (?:terms|license) as perl itself' => 'perl',
- 'GNU public license' => 'gpl',
- 'GNU lesser public license' => 'gpl',
- 'BSD license' => 'bsd',
- 'Artistic license' => 'artistic',
- 'GPL' => 'gpl',
- 'LGPL' => 'lgpl',
- 'BSD' => 'bsd',
- 'Artistic' => 'artistic',
- 'MIT' => 'MIT',
- );
- while ( my ( $pattern, $license ) = splice( @phrases, 0, 2 ) ) {
- $pattern =~ s{\s+}{\\s+}g;
- if ( $license_text =~ /\b$pattern\b/i ) {
- $self->license($license);
- return 1;
- }
- }
- }
-
- warn "Cannot determine license info from $file\n";
- return 'unknown';
-}
-
-1;
@@ -1,65 +0,0 @@
-#line 1
-package Module::Install::Win32;
-
-use strict;
-use Module::Install::Base;
-
-use vars qw{$VERSION $ISCORE @ISA};
-BEGIN {
- $VERSION = '0.65';
- $ISCORE = 1;
- @ISA = qw{Module::Install::Base};
-}
-
-# determine if the user needs nmake, and download it if needed
-sub check_nmake {
- my $self = shift;
- $self->load('can_run');
- $self->load('get_file');
-
- require Config;
- return unless (
- $^O eq 'MSWin32' and
- $Config::Config{make} and
- $Config::Config{make} =~ /^nmake\b/i and
- ! $self->can_run('nmake')
- );
-
- print "The required 'nmake' executable not found, fetching it...\n";
-
- require File::Basename;
- my $rv = $self->get_file(
- url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe',
- ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe',
- local_dir => File::Basename::dirname($^X),
- size => 51928,
- run => 'Nmake15.exe /o > nul',
- check_for => 'Nmake.exe',
- remove => 1,
- );
-
- if (!$rv) {
- die <<'END_MESSAGE';
-
--------------------------------------------------------------------------------
-
-Since you are using Microsoft Windows, you will need the 'nmake' utility
-before installation. It's available at:
-
- http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe
- or
- ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe
-
-Please download the file manually, save it to a directory in %PATH% (e.g.
-C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to
-that directory, and run "Nmake15.exe" from there; that will create the
-'nmake.exe' file needed by this module.
-
-You may then resume the installation process described in README.
-
--------------------------------------------------------------------------------
-END_MESSAGE
- }
-}
-
-1;
@@ -1,43 +0,0 @@
-#line 1
-package Module::Install::WriteAll;
-
-use strict;
-use Module::Install::Base;
-
-use vars qw{$VERSION $ISCORE @ISA};
-BEGIN {
- $VERSION = '0.65';
- $ISCORE = 1;
- @ISA = qw{Module::Install::Base};
-}
-
-sub WriteAll {
- my $self = shift;
- my %args = (
- meta => 1,
- sign => 0,
- inline => 0,
- check_nmake => 1,
- @_
- );
-
- $self->sign(1) if $args{sign};
- $self->Meta->write if $args{meta};
- $self->admin->WriteAll(%args) if $self->is_admin;
-
- if ( $0 =~ /Build.PL$/i ) {
- $self->Build->write;
- } else {
- $self->check_nmake if $args{check_nmake};
- unless ( $self->makemaker_args->{'PL_FILES'} ) {
- $self->makemaker_args( PL_FILES => {} );
- }
- if ($args{inline}) {
- $self->Inline->write;
- } else {
- $self->Makefile->write;
- }
- }
-}
-
-1;
@@ -1,281 +0,0 @@
-#line 1
-package Module::Install;
-
-# For any maintainers:
-# The load order for Module::Install is a bit magic.
-# It goes something like this...
-#
-# IF ( host has Module::Install installed, creating author mode ) {
-# 1. Makefile.PL calls "use inc::Module::Install"
-# 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install
-# 3. The installed version of inc::Module::Install loads
-# 4. inc::Module::Install calls "require Module::Install"
-# 5. The ./inc/ version of Module::Install loads
-# } ELSE {
-# 1. Makefile.PL calls "use inc::Module::Install"
-# 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install
-# 3. The ./inc/ version of Module::Install loads
-# }
-
-use 5.004;
-use strict 'vars';
-
-use vars qw{$VERSION};
-BEGIN {
- # All Module::Install core packages now require synchronised versions.
- # This will be used to ensure we don't accidentally load old or
- # different versions of modules.
- # This is not enforced yet, but will be some time in the next few
- # releases once we can make sure it won't clash with custom
- # Module::Install extensions.
- $VERSION = '0.65';
-}
-
-# Whether or not inc::Module::Install is actually loaded, the
-# $INC{inc/Module/Install.pm} is what will still get set as long as
-# the caller loaded module this in the documented manner.
-# If not set, the caller may NOT have loaded the bundled version, and thus
-# they may not have a MI version that works with the Makefile.PL. This would
-# result in false errors or unexpected behaviour. And we don't want that.
-my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
-unless ( $INC{$file} ) {
- die <<"END_DIE";
-Please invoke ${\__PACKAGE__} with:
-
- use inc::${\__PACKAGE__};
-
-not:
-
- use ${\__PACKAGE__};
-
-END_DIE
-}
-
-# If the script that is loading Module::Install is from the future,
-# then make will detect this and cause it to re-run over and over
-# again. This is bad. Rather than taking action to touch it (which
-# is unreliable on some platforms and requires write permissions)
-# for now we should catch this and refuse to run.
-if ( -f $0 and (stat($0))[9] > time ) {
- die << "END_DIE";
-Your installer $0 has a modification time in the future.
-
-This is known to create infinite loops in make.
-
-Please correct this, then run $0 again.
-
-END_DIE
-}
-
-use Cwd ();
-use File::Find ();
-use File::Path ();
-use FindBin;
-
-*inc::Module::Install::VERSION = *VERSION;
-@inc::Module::Install::ISA = __PACKAGE__;
-
-sub autoload {
- my $self = shift;
- my $who = $self->_caller;
- my $cwd = Cwd::cwd();
- my $sym = "${who}::AUTOLOAD";
- $sym->{$cwd} = sub {
- my $pwd = Cwd::cwd();
- if ( my $code = $sym->{$pwd} ) {
- # delegate back to parent dirs
- goto &$code unless $cwd eq $pwd;
- }
- $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
- unshift @_, ($self, $1);
- goto &{$self->can('call')} unless uc($1) eq $1;
- };
-}
-
-sub import {
- my $class = shift;
- my $self = $class->new(@_);
- my $who = $self->_caller;
-
- unless ( -f $self->{file} ) {
- require "$self->{path}/$self->{dispatch}.pm";
- File::Path::mkpath("$self->{prefix}/$self->{author}");
- $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
- $self->{admin}->init;
- @_ = ($class, _self => $self);
- goto &{"$self->{name}::import"};
- }
-
- *{"${who}::AUTOLOAD"} = $self->autoload;
- $self->preload;
-
- # Unregister loader and worker packages so subdirs can use them again
- delete $INC{"$self->{file}"};
- delete $INC{"$self->{path}.pm"};
-}
-
-sub preload {
- my ($self) = @_;
-
- unless ( $self->{extensions} ) {
- $self->load_extensions(
- "$self->{prefix}/$self->{path}", $self
- );
- }
-
- my @exts = @{$self->{extensions}};
- unless ( @exts ) {
- my $admin = $self->{admin};
- @exts = $admin->load_all_extensions;
- }
-
- my %seen;
- foreach my $obj ( @exts ) {
- while (my ($method, $glob) = each %{ref($obj) . '::'}) {
- next unless $obj->can($method);
- next if $method =~ /^_/;
- next if $method eq uc($method);
- $seen{$method}++;
- }
- }
-
- my $who = $self->_caller;
- foreach my $name ( sort keys %seen ) {
- *{"${who}::$name"} = sub {
- ${"${who}::AUTOLOAD"} = "${who}::$name";
- goto &{"${who}::AUTOLOAD"};
- };
- }
-}
-
-sub new {
- my ($class, %args) = @_;
-
- # ignore the prefix on extension modules built from top level.
- my $base_path = Cwd::abs_path($FindBin::Bin);
- unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
- delete $args{prefix};
- }
-
- return $args{_self} if $args{_self};
-
- $args{dispatch} ||= 'Admin';
- $args{prefix} ||= 'inc';
- $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author');
- $args{bundle} ||= 'inc/BUNDLES';
- $args{base} ||= $base_path;
- $class =~ s/^\Q$args{prefix}\E:://;
- $args{name} ||= $class;
- $args{version} ||= $class->VERSION;
- unless ( $args{path} ) {
- $args{path} = $args{name};
- $args{path} =~ s!::!/!g;
- }
- $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm";
-
- bless( \%args, $class );
-}
-
-sub call {
- my ($self, $method) = @_;
- my $obj = $self->load($method) or return;
- splice(@_, 0, 2, $obj);
- goto &{$obj->can($method)};
-}
-
-sub load {
- my ($self, $method) = @_;
-
- $self->load_extensions(
- "$self->{prefix}/$self->{path}", $self
- ) unless $self->{extensions};
-
- foreach my $obj (@{$self->{extensions}}) {
- return $obj if $obj->can($method);
- }
-
- my $admin = $self->{admin} or die <<"END_DIE";
-The '$method' method does not exist in the '$self->{prefix}' path!
-Please remove the '$self->{prefix}' directory and run $0 again to load it.
-END_DIE
-
- my $obj = $admin->load($method, 1);
- push @{$self->{extensions}}, $obj;
-
- $obj;
-}
-
-sub load_extensions {
- my ($self, $path, $top) = @_;
-
- unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
- unshift @INC, $self->{prefix};
- }
-
- foreach my $rv ( $self->find_extensions($path) ) {
- my ($file, $pkg) = @{$rv};
- next if $self->{pathnames}{$pkg};
-
- local $@;
- my $new = eval { require $file; $pkg->can('new') };
- unless ( $new ) {
- warn $@ if $@;
- next;
- }
- $self->{pathnames}{$pkg} = delete $INC{$file};
- push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
- }
-
- $self->{extensions} ||= [];
-}
-
-sub find_extensions {
- my ($self, $path) = @_;
-
- my @found;
- File::Find::find( sub {
- my $file = $File::Find::name;
- return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
- my $subpath = $1;
- return if lc($subpath) eq lc($self->{dispatch});
-
- $file = "$self->{path}/$subpath.pm";
- my $pkg = "$self->{name}::$subpath";
- $pkg =~ s!/!::!g;
-
- # If we have a mixed-case package name, assume case has been preserved
- # correctly. Otherwise, root through the file to locate the case-preserved
- # version of the package name.
- if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
- open PKGFILE, "<$subpath.pm" or die "find_extensions: Can't open $subpath.pm: $!";
- my $in_pod = 0;
- while ( <PKGFILE> ) {
- $in_pod = 1 if /^=\w/;
- $in_pod = 0 if /^=cut/;
- next if ($in_pod || /^=cut/); # skip pod text
- next if /^\s*#/; # and comments
- if ( m/^\s*package\s+($pkg)\s*;/i ) {
- $pkg = $1;
- last;
- }
- }
- close PKGFILE;
- }
-
- push @found, [ $file, $pkg ];
- }, $path ) if -d $path;
-
- @found;
-}
-
-sub _caller {
- my $depth = 0;
- my $call = caller($depth);
- while ( $call eq __PACKAGE__ ) {
- $depth++;
- $call = caller($depth);
- }
- return $call;
-}
-
-1;
@@ -1,4 +1,11 @@
package Catalyst::Engine::Apache::MP13;
+BEGIN {
+ $Catalyst::Engine::Apache::MP13::AUTHORITY = 'cpan:BOBTFISH';
+}
+BEGIN {
+ $Catalyst::Engine::Apache::MP13::VERSION = '1.16';
+}
+# ABSTRACT: Catalyst Apache mod_perl 1.3x Engine
use strict;
use warnings;
@@ -11,11 +18,11 @@ use Apache::Util ();
sub finalize_headers {
my ( $self, $c ) = @_;
-
+
$self->SUPER::finalize_headers( $c );
-
+
$self->apache->send_http_header;
-
+
return 0;
}
@@ -29,7 +36,12 @@ sub unescape_uri {
}
1;
+
+
__END__
+=pod
+
+=encoding utf-8
=head1 NAME
@@ -41,32 +53,32 @@ Catalyst::Engine::Apache::MP13 - Catalyst Apache mod_perl 1.3x Engine
<Perl>
use lib qw( /var/www/MyApp/lib );
</Perl>
-
+
# Preload your entire application
PerlModule MyApp
-
+
<VirtualHost *>
ServerName myapp.hostname.com
DocumentRoot /var/www/MyApp/root
-
+
<Location />
SetHandler perl-script
PerlHandler MyApp
</Location>
-
+
# you can also run your app in any non-root location
<Location /some/other/path>
SetHandler perl-script
PerlHandler MyApp
</Location>
-
+
# Make sure to let Apache handle your static files
# (And remember to remove the Static::Simple plugin in production)
<Location /static>
SetHandler default-handler
</Location>
</VirtualHost>
-
+
=head1 DESCRIPTION
This is the Catalyst engine specialized for Apache mod_perl version 1.3x.
@@ -80,26 +92,26 @@ httpd.conf:
PerlModule Apache::Registry
Alias / /var/www/MyApp/script/myapp_registry.pl/
-
+
<Directory /var/www/MyApp/script>
Options +ExecCGI
</Directory>
-
+
<Location />
SetHandler perl-script
PerlHandler Apache::Registry
</Location>
-
+
script/myapp_registry.pl (you will need to create this):
#!/usr/bin/perl
-
+
use strict;
use warnings;
use MyApp;
-
+
MyApp->handle_request( Apache->request );
-
+
=head1 METHODS
=head2 ok_constant
@@ -116,15 +128,32 @@ L<Catalyst>, L<Catalyst::Engine>, L<Catalyst::Engine::Apache>.
=head1 AUTHORS
-Sebastian Riedel, <sri@cpan.org>
+=over 4
+
+=item *
+
+Sebastian Riedel <sri@cpan.org>
-Christian Hansen, <ch@ngmedia.com>
+=item *
-Andy Grundman, <andy@hybridized.org>
+Christian Hansen <ch@ngmedia.com>
-=head1 COPYRIGHT
+=item *
-This program is free software, you can redistribute it and/or modify it under
-the same terms as Perl itself.
+Andy Grundman <andy@hybridized.org>
+
+=item *
+
+Tomas Doran <bobtfish@bobtfish.net>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2010 by The "AUTHORS".
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
=cut
+
@@ -1,4 +1,11 @@
package Catalyst::Engine::Apache;
+BEGIN {
+ $Catalyst::Engine::Apache::AUTHORITY = 'cpan:BOBTFISH';
+}
+BEGIN {
+ $Catalyst::Engine::Apache::VERSION = '1.16';
+}
+# ABSTRACT: Catalyst Apache Engines
use strict;
use warnings;
@@ -9,13 +16,11 @@ use URI;
use URI::http;
use URI::https;
-use constant MP2 => (
- exists $ENV{MOD_PERL_API_VERSION} and
+use constant MP2 => (
+ exists $ENV{MOD_PERL_API_VERSION} and
$ENV{MOD_PERL_API_VERSION} >= 2
);
-our $VERSION = '1.12';
-
__PACKAGE__->mk_accessors(qw/apache return/);
sub prepare_request {
@@ -35,7 +40,7 @@ sub prepare_connection {
unless ( $c->config->{using_frontend_proxy} ) {
last PROXY_CHECK if $c->request->address ne '127.0.0.1';
last PROXY_CHECK if $c->config->{ignore_frontend_proxy};
- }
+ }
last PROXY_CHECK unless $headers->{'X-Forwarded-For'};
# If we are running as a backend server, the user will always appear
@@ -47,12 +52,13 @@ sub prepare_connection {
$c->request->hostname( $self->apache->connection->remote_host );
$c->request->protocol( $self->apache->protocol );
$c->request->user( $self->apache->user );
+ $c->request->remote_user( $self->apache->user );
# when config options are set, check them here first
if ($INC{'Apache2/ModSSL.pm'}) {
$c->request->secure(1) if $self->apache->connection->is_https;
} else {
- my $https = $self->apache->subprocess_env('HTTPS');
+ my $https = $self->apache->subprocess_env('HTTPS');
$c->request->secure(1) if defined $https and uc $https eq 'ON';
}
@@ -60,7 +66,7 @@ sub prepare_connection {
sub prepare_query_parameters {
my ( $self, $c ) = @_;
-
+
if ( my $query_string = $self->apache->args ) {
$self->SUPER::prepare_query_parameters( $c, $query_string );
}
@@ -91,7 +97,7 @@ sub prepare_path {
last PROXY_CHECK if $c->config->{ignore_frontend_proxy};
}
last PROXY_CHECK unless $c->request->header( 'X-Forwarded-Host' );
-
+
$host = $c->request->header( 'X-Forwarded-Host' );
if ( $host =~ /^(.+):(\d+)$/ ) {
@@ -111,19 +117,19 @@ sub prepare_path {
if ( $location && $location ne '/' ) {
$base_path = $location;
}
-
+
# Using URI directly is way too slow, so we construct the URLs manually
my $uri_class = "URI::$scheme";
-
+
if ( $port !~ /^(?:80|443)$/ && $host !~ /:/ ) {
$host .= ":$port";
}
-
+
# We want the path before Apache escapes it. Under mod_perl2 this is available
# with the unparsed_uri method. Under mod_perl 1 we must parse it out of the
# request line.
my ($path, $qs);
-
+
if ( MP2 ) {
($path, $qs) = split /\?/, $self->apache->unparsed_uri, 2;
}
@@ -131,13 +137,13 @@ sub prepare_path {
my (undef, $path_query) = split / /, $self->apache->the_request, 3;
($path, $qs) = split /\?/, $path_query, 2;
}
-
+
# Don't check for LocationMatch blocks if requested
# http://rt.cpan.org/Ticket/Display.html?id=26921
if ( $self->apache->dir_config('CatalystDisableLocationMatch') ) {
$base_path = '';
}
-
+
# Check if $base_path appears to be a regex (contains invalid characters),
# meaning we're in a LocationMatch block
elsif ( $base_path =~ m/[^$URI::uric]/o ) {
@@ -145,13 +151,13 @@ sub prepare_path {
# that will become our base
my $match = qr/($base_path)/;
my ($base_match) = $path =~ $match;
-
+
$base_path = $base_match || '';
}
# Strip leading slash
$path =~ s{^/+}{};
-
+
# base must end in a slash
$base_path .= '/' unless $base_path =~ m{/$};
@@ -161,7 +167,7 @@ sub prepare_path {
if ( defined $ENV{SCRIPT_NAME} && $self->apache->filename && -f $self->apache->filename && -x _ ) {
$base_path .= $ENV{SCRIPT_NAME};
}
-
+
# If the path is contained within the base, we need to make the path
# match base. This handles the case where the app is running at /deep/path
# but a request to /deep/path fails where /deep/path/ does not.
@@ -169,12 +175,12 @@ sub prepare_path {
$path = $base_path;
$path =~ s{^/+}{};
}
-
+
my $query = $qs ? '?' . $qs : '';
my $uri = $scheme . '://' . $host . '/' . $path . $query;
$c->request->uri( bless \$uri, $uri_class );
-
+
my $base_uri = $scheme . '://' . $host . $base_path;
$c->request->base( bless \$base_uri, $uri_class );
@@ -183,15 +189,15 @@ sub prepare_path {
sub read_chunk {
my $self = shift;
my $c = shift;
-
+
$self->apache->read( @_ );
}
sub finalize_body {
my ( $self, $c ) = @_;
-
+
$self->SUPER::finalize_body($c);
-
+
# Data sent using $self->apache->print is buffered, so we need
# to flush it after we are done writing.
$self->apache->rflush;
@@ -244,7 +250,12 @@ sub write {
}
1;
+
+
__END__
+=pod
+
+=encoding utf-8
=head1 NAME
@@ -275,7 +286,7 @@ $c->apache.
=head2 $c->engine->return
-If you need to return something other than OK from the mod_perl handler,
+If you need to return something other than OK from the mod_perl handler,
you may set any other Apache constant in this method. You should only use
this method if you know what you are doing or bad things may happen!
For example, to return DECLINED in mod_perl 2:
@@ -301,29 +312,37 @@ by adding this to your configuration:
PerlSetVar CatalystDisableLocationMatch 1
+=head2 NOTES ON NON-STANDARD PORTS
+
+If you wish to run your site on a non-standard port you will need to use the
+C<Port> Apache config rather than C<Listen>. This will result in the correct
+port being added to urls created using C<uri_for>.
+
+ Port 8080
+
=head1 OVERLOADED METHODS
This class overloads some methods from C<Catalyst::Engine>.
=over 4
-=item $c->engine->prepare_request($r)
+=item prepare_request($r)
-=item $c->engine->prepare_connection
+=item prepare_connection
-=item $c->engine->prepare_query_parameters
+=item prepare_query_parameters
-=item $c->engine->prepare_headers
+=item prepare_headers
-=item $c->engine->prepare_path
+=item prepare_path
-=item $c->engine->read_chunk
+=item read_chunk
-=item $c->engine->finalize_body
+=item finalize_body
-=item $c->engine->finalize_headers
+=item finalize_headers
-=item $c->engine->write
+=item write
=back
@@ -333,15 +352,32 @@ L<Catalyst> L<Catalyst::Engine>.
=head1 AUTHORS
-Sebastian Riedel, <sri@cpan.org>
+=over 4
+
+=item *
-Christian Hansen, <ch@ngmedia.com>
+Sebastian Riedel <sri@cpan.org>
-Andy Grundman, <andy@hybridized.org>
+=item *
-=head1 COPYRIGHT
+Christian Hansen <ch@ngmedia.com>
-This program is free software, you can redistribute it and/or modify it under
-the same terms as Perl itself.
+=item *
+
+Andy Grundman <andy@hybridized.org>
+
+=item *
+
+Tomas Doran <bobtfish@bobtfish.net>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2010 by The "AUTHORS".
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
=cut
+
@@ -1,4 +1,11 @@
package Catalyst::Engine::Apache2::MP19;
+BEGIN {
+ $Catalyst::Engine::Apache2::MP19::AUTHORITY = 'cpan:BOBTFISH';
+}
+BEGIN {
+ $Catalyst::Engine::Apache2::MP19::VERSION = '1.16';
+}
+# ABSTRACT: Catalyst Apache2 mod_perl 1.99x Engine
use strict;
use warnings;
@@ -18,13 +25,18 @@ sub ok_constant { Apache::OK }
sub unescape_uri {
my ( $self, $str ) = @_;
-
+
$str =~ s/\+/ /g;
return Apache::URI::unescape_url($str);
}
1;
+
+
__END__
+=pod
+
+=encoding utf-8
=head1 NAME
@@ -34,30 +46,46 @@ Catalyst::Engine::Apache2::MP19 - Catalyst Apache2 mod_perl 1.99x Engine
# Set up your Catalyst app as a mod_perl 1.99x application in httpd.conf
PerlSwitches -I/var/www/MyApp/lib
-
+
# Preload your entire application
PerlModule MyApp
-
+
<VirtualHost *>
ServerName myapp.hostname.com
DocumentRoot /var/www/MyApp/root
-
+
<Location />
SetHandler modperl
PerlResponseHandler MyApp
</Location>
-
+
# you can also run your app in any non-root location
<Location /some/other/path>
SetHandler perl-script
PerlResponseHandler MyApp
</Location>
-
+
# Make sure to let Apache handle your static files
- # (And remember to remove the Static::Simple plugin in production)
+ # (It is not necessary to remove the Static::Simple plugin
+ # in production; Apache will bypass Static::Simple if
+ # configured in this way)
+
<Location /static>
SetHandler default-handler
- </Location>
+ </Location>
+
+ # If not running at a root location in a VirtualHost,
+ # you'll probably need to set an Alias to the location
+ # of your static files, and allow access to this location:
+
+ Alias /myapp/static /filesystem/path/to/MyApp/root/static
+ <Directory /filesystem/path/to/MyApp/root/static>
+ allow from all
+ </Directory>
+ <Location /myapp/static>
+ SetHandler default-handler
+ </Location>
+
</VirtualHost>
=head1 DESCRIPTION
@@ -83,26 +111,26 @@ httpd.conf:
PerlModule ModPerl::Registry
Alias / /var/www/MyApp/script/myapp_registry.pl/
-
+
<Directory /var/www/MyApp/script>
Options +ExecCGI
</Directory>
-
+
<Location />
SetHandler perl-script
PerlResponseHandler ModPerl::Registry
</Location>
-
+
script/myapp_registry.pl (you will need to create this):
#!/usr/bin/perl
-
+
use strict;
use warnings;
use MyApp;
-
+
MyApp->handle_request( Apache::RequestUtil->request );
-
+
=head1 METHODS
=head2 ok_constant
@@ -113,15 +141,32 @@ L<Catalyst>, L<Catalyst::Engine>, L<Catalyst::Engine::Apache2>.
=head1 AUTHORS
-Sebastian Riedel, <sri@cpan.org>
+=over 4
+
+=item *
-Christian Hansen, <ch@ngmedia.com>
+Sebastian Riedel <sri@cpan.org>
-Andy Grundman, <andy@hybridized.org>
+=item *
-=head1 COPYRIGHT
+Christian Hansen <ch@ngmedia.com>
-This program is free software, you can redistribute it and/or modify it under
-the same terms as Perl itself.
+=item *
+
+Andy Grundman <andy@hybridized.org>
+
+=item *
+
+Tomas Doran <bobtfish@bobtfish.net>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2010 by The "AUTHORS".
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
=cut
+
@@ -1,4 +1,11 @@
package Catalyst::Engine::Apache2::MP20;
+BEGIN {
+ $Catalyst::Engine::Apache2::MP20::AUTHORITY = 'cpan:BOBTFISH';
+}
+BEGIN {
+ $Catalyst::Engine::Apache2::MP20::VERSION = '1.16';
+}
+# ABSTRACT: Catalyst Apache2 mod_perl 2.x Engine
use strict;
use warnings;
@@ -20,13 +27,18 @@ sub ok_constant { Apache2::Const::OK }
sub unescape_uri {
my ( $self, $str ) = @_;
-
+
$str =~ s/\+/ /g;
return Apache2::URI::unescape_url($str);
}
1;
+
+
__END__
+=pod
+
+=encoding utf-8
=head1 NAME
@@ -36,30 +48,46 @@ Catalyst::Engine::Apache2::MP20 - Catalyst Apache2 mod_perl 2.x Engine
# Set up your Catalyst app as a mod_perl 2.x application in httpd.conf
PerlSwitches -I/var/www/MyApp/lib
-
+
# Preload your entire application
PerlModule MyApp
-
+
<VirtualHost *>
ServerName myapp.hostname.com
DocumentRoot /var/www/MyApp/root
-
+
<Location />
SetHandler modperl
PerlResponseHandler MyApp
</Location>
-
+
# you can also run your app in any non-root location
<Location /some/other/path>
SetHandler perl-script
PerlResponseHandler MyApp
</Location>
-
+
# Make sure to let Apache handle your static files
- # (And remember to remove the Static::Simple plugin in production)
+ # (It is not necessary to remove the Static::Simple plugin
+ # in production; Apache will bypass Static::Simple if
+ # configured in this way)
+
<Location /static>
SetHandler default-handler
</Location>
+
+ # If not running at a root location in a VirtualHost,
+ # you'll probably need to set an Alias to the location
+ # of your static files, and allow access to this location:
+
+ Alias /myapp/static /filesystem/path/to/MyApp/root/static
+ <Directory /filesystem/path/to/MyApp/root/static>
+ allow from all
+ </Directory>
+ <Location /myapp/static>
+ SetHandler default-handler
+ </Location>
+
</VirtualHost>
=head1 DESCRIPTION
@@ -75,45 +103,82 @@ httpd.conf:
PerlModule ModPerl::Registry
Alias / /var/www/MyApp/script/myapp_registry.pl/
-
+
<Directory /var/www/MyApp/script>
Options +ExecCGI
</Directory>
-
+
<Location />
SetHandler perl-script
PerlResponseHandler ModPerl::Registry
</Location>
-
+
script/myapp_registry.pl (you will need to create this):
#!/usr/bin/perl
-
+
use strict;
use warnings;
use MyApp;
-
+
MyApp->handle_request( Apache2::RequestUtil->request );
=head1 METHODS
=head2 ok_constant
+=head1 OVERLOADED METHODS
+
+This class overloads some methods from C<Catalyst::Engine>.
+
+=over 4
+
+=item unescape_uri
+
+=back
+
+=head1 OVERLOADED METHODS
+
+This class overloads some methods from C<Catalyst::Engine>.
+
+=over 4
+
+=item unescape_uri
+
+=back
+
=head1 SEE ALSO
L<Catalyst>, L<Catalyst::Engine>, L<Catalyst::Engine::Apache2>.
=head1 AUTHORS
-Sebastian Riedel, <sri@cpan.org>
+=over 4
+
+=item *
+
+Sebastian Riedel <sri@cpan.org>
+
+=item *
+
+Christian Hansen <ch@ngmedia.com>
-Christian Hansen, <ch@ngmedia.com>
+=item *
-Andy Grundman, <andy@hybridized.org>
+Andy Grundman <andy@hybridized.org>
-=head1 COPYRIGHT
+=item *
-This program is free software, you can redistribute it and/or modify it under
-the same terms as Perl itself.
+Tomas Doran <bobtfish@bobtfish.net>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2010 by The "AUTHORS".
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
=cut
+
@@ -1,4 +1,11 @@
package Catalyst::Engine::Apache2;
+BEGIN {
+ $Catalyst::Engine::Apache2::AUTHORITY = 'cpan:BOBTFISH';
+}
+BEGIN {
+ $Catalyst::Engine::Apache2::VERSION = '1.16';
+}
+# ABSTRACT: Base class for Apache 1.99x and 2.x Engines
use strict;
use warnings;
@@ -20,7 +27,12 @@ sub finalize_headers {
}
1;
+
+
__END__
+=pod
+
+=encoding utf-8
=head1 NAME
@@ -40,7 +52,7 @@ This class overloads some methods from C<Catalyst::Engine>.
=over 4
-=item $c->engine->finalize_headers
+=item finalize_headers
=back
@@ -50,15 +62,32 @@ L<Catalyst> L<Catalyst::Engine>.
=head1 AUTHORS
-Sebastian Riedel, <sri@cpan.org>
+=over 4
+
+=item *
+
+Sebastian Riedel <sri@cpan.org>
-Christian Hansen, <ch@ngmedia.com>
+=item *
-Andy Grundman, <andy@hybridized.org>
+Christian Hansen <ch@ngmedia.com>
-=head1 COPYRIGHT
+=item *
-This program is free software, you can redistribute it and/or modify it under
-the same terms as Perl itself.
+Andy Grundman <andy@hybridized.org>
+
+=item *
+
+Tomas Doran <bobtfish@bobtfish.net>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2010 by The "AUTHORS".
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
=cut
+
@@ -0,0 +1,9 @@
+use strict;
+use warnings;
+
+use Test::More 0.88;
+
+use_ok 'Catalyst::Engine::Apache';
+
+done_testing;
+
@@ -1,7 +0,0 @@
-use Test::More;
-
-eval "use Test::Pod 1.14";
-plan skip_all => 'Test::Pod 1.14 required' if $@;
-plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD};
-
-all_pod_files_ok();
@@ -1,7 +0,0 @@
-use Test::More;
-
-eval "use Test::Pod::Coverage 1.04";
-plan skip_all => 'Test::Pod::Coverage 1.04 required' if $@;
-plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD};
-
-all_pod_coverage_ok();
@@ -0,0 +1,118 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 28 * $iters;
+use Catalyst::Test 'TestApp';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+ {
+ ok( my $response = request('http://localhost/action_action_one'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action_action_one', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Action',
+ 'Test Class'
+ );
+ is( $response->header('X-Action'), 'works' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ ok( my $response = request('http://localhost/action_action_two'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action_action_two', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Action',
+ 'Test Class'
+ );
+ is( $response->header('X-Action-After'), 'awesome' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ ok(
+ my $response =
+ request('http://localhost/action_action_three/one/two'),
+ 'Request'
+ );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action_action_three', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Action',
+ 'Test Class'
+ );
+ is( $response->header('X-TestAppActionTestBefore'), 'one' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ ok( my $response = request('http://localhost/action_action_four'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action_action_four', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Action',
+ 'Test Class'
+ );
+ is( $response->header('X-TestAppActionTestMyAction'), 'MyAction works' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+}
@@ -0,0 +1,144 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 18*$iters;
+use Catalyst::Test 'TestApp';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+
+ # new dispatcher:
+ # 11 wallclock secs (10.14 usr + 0.20 sys = 10.34 CPU) @ 15.18/s (n=157)
+ # old dispatcher (r1486):
+ # 11 wallclock secs (10.34 usr + 0.20 sys = 10.54 CPU) @ 13.76/s (n=145)
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+ # test auto + local method
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Auto->begin
+ TestApp::Controller::Action::Auto->auto
+ TestApp::Controller::Action::Auto->one
+ TestApp::Controller::Root->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action/auto/one'), 'auto + local' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, 'one', 'Content OK' );
+ }
+
+ # test auto + default
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Auto->begin
+ TestApp::Controller::Action::Auto->auto
+ TestApp::Controller::Action::Auto->default
+ TestApp::Controller::Root->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action/auto/anything'), 'auto + default' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, 'default', 'Content OK' );
+ }
+
+ # test auto + auto + local
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Auto::Deep->begin
+ TestApp::Controller::Action::Auto->auto
+ TestApp::Controller::Action::Auto::Deep->auto
+ TestApp::Controller::Action::Auto::Deep->one
+ TestApp::Controller::Root->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action/auto/deep/one'), 'auto + auto + local' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, 'deep one', 'Content OK' );
+ }
+
+ # test auto + auto + default
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Auto::Deep->begin
+ TestApp::Controller::Action::Auto->auto
+ TestApp::Controller::Action::Auto::Deep->auto
+ TestApp::Controller::Action::Auto::Deep->default
+ TestApp::Controller::Root->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action/auto/deep/anything'), 'auto + auto + default' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, 'deep default', 'Content OK' );
+ }
+
+ # test auto + failing auto + local + end
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Auto::Abort->begin
+ TestApp::Controller::Action::Auto->auto
+ TestApp::Controller::Action::Auto::Abort->auto
+ TestApp::Controller::Action::Auto::Abort->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action/auto/abort/one'), 'auto + failing auto + local' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, 'abort end', 'Content OK' );
+ }
+
+ # test auto + default (bug on invocation of default twice)
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Auto::Default->begin
+ TestApp::Controller::Action::Auto->auto
+ TestApp::Controller::Action::Auto::Default->auto
+ TestApp::Controller::Action::Auto::Default->default
+ TestApp::Controller::Action::Auto::Default->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action/auto/default/moose'), 'auto + default' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, 'default (auto: 1)', 'Content OK' );
+ }
+}
@@ -0,0 +1,61 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 7*$iters;
+use Catalyst::Test 'TestApp';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Begin->begin
+ TestApp::Controller::Action::Begin->default
+ TestApp::View::Dump::Request->process
+ TestApp::Controller::Root->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action/begin'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'), 'default', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Begin',
+ 'Test Class'
+ );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ like( $response->content, qr/'Catalyst::Request'/,
+ 'Content is a serialized Catalyst::Request' );
+ }
+}
@@ -0,0 +1,839 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 118*$iters;
+use Catalyst::Test 'TestApp';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests($_);
+ }
+}
+
+sub run_tests {
+ my ($run_number) = @_;
+
+ #
+ # This is a simple test where the parent and child actions are
+ # within the same controller.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->foo
+ TestApp::Controller::Action::Chained->endpoint
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/foo/1/end/2'), 'chained + local endpoint' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; 2', 'Content OK' );
+ }
+
+ #
+ # This makes sure the above isn't found if the argument for the
+ # end action isn't supplied.
+ #
+ {
+ my $expected = undef;
+
+ ok( my $response = request('http://localhost/chained/foo/1/end'),
+ 'chained + local endpoint; missing last argument' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->code, 500, 'Status OK' );
+ }
+
+ #
+ # Tests the case when the child action is placed in a subcontroller.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->foo
+ TestApp::Controller::Action::Chained::Foo->spoon
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/foo/1/spoon'), 'chained + subcontroller endpoint' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; ', 'Content OK' );
+ }
+
+ #
+ # Tests if the relative specification (e.g.: Chained('bar') ) works
+ # as expected.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->bar
+ TestApp::Controller::Action::Chained->finale
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/bar/1/spoon'), 'chained + relative endpoint' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '; 1, spoon', 'Content OK' );
+ }
+
+ #
+ # Just a test for multiple arguments.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->foo2
+ TestApp::Controller::Action::Chained->endpoint2
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/foo2/10/20/end2/15/25'),
+ 'chained + local (2 args each)' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '10, 20; 15, 25', 'Content OK' );
+ }
+
+ #
+ # The first three-chain test tries to call the action with :Args(1)
+ # specification. There's also a one action with a :CaptureArgs(1)
+ # attribute, that should not be dispatched to.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->one_end
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/one/23'),
+ 'three-chain (only first)' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '; 23', 'Content OK' );
+ }
+
+ #
+ # This is the second three-chain test, it goes for the action that
+ # handles "/one/$cap/two/$arg1/$arg2" paths. Should be the two action
+ # having :Args(2), not the one having :CaptureArgs(2).
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->one
+ TestApp::Controller::Action::Chained->two_end
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/one/23/two/23/46'),
+ 'three-chain (up to second)' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '23; 23, 46', 'Content OK' );
+ }
+
+ #
+ # Last of the three-chain tests. Has no concurrent action with :CaptureArgs
+ # and is more thought to simply test the chain as a whole and the 'two'
+ # action specifying :CaptureArgs.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->one
+ TestApp::Controller::Action::Chained->two
+ TestApp::Controller::Action::Chained->three_end
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/one/23/two/23/46/three/1/2/3'),
+ 'three-chain (all three)' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '23, 23, 46; 1, 2, 3', 'Content OK' );
+ }
+
+ #
+ # Tests dispatching on number of arguments for :Args. This should be
+ # dispatched to the action expecting one argument.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->multi1
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/multi/23'),
+ 'multi-action (one arg)' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '; 23', 'Content OK' );
+ }
+
+ #
+ # Belongs to the former test and goes for the action expecting two arguments.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->multi2
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/multi/23/46'),
+ 'multi-action (two args)' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '; 23, 46', 'Content OK' );
+ }
+
+ #
+ # Dispatching on argument count again, this time we provide too many
+ # arguments, so dispatching should fail.
+ #
+ {
+ my $expected = undef;
+
+ ok( my $response = request('http://localhost/chained/multi/23/46/67'),
+ 'multi-action (three args, should lead to error)' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->code, 500, 'Status OK' );
+ }
+
+ #
+ # This tests the case when an action says it's the child of an action in
+ # a subcontroller.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained::Foo->higher_root
+ TestApp::Controller::Action::Chained->higher_root
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/higher_root/23/bar/11'),
+ 'root higher than child' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '23; 11', 'Content OK' );
+ }
+
+ #
+ # Just a more complex version of the former test. It tests if a controller ->
+ # subcontroller -> controller dispatch works.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->pcp1
+ TestApp::Controller::Action::Chained::Foo->pcp2
+ TestApp::Controller::Action::Chained->pcp3
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/pcp1/1/pcp2/2/pcp3/3'),
+ 'parent -> child -> parent' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1, 2; 3', 'Content OK' );
+ }
+
+ #
+ # Tests dispatch on capture number. This test is for a one capture action.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->multi_cap1
+ TestApp::Controller::Action::Chained->multi_cap_end1
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/multi_cap/1/baz'),
+ 'dispatch on capture num 1' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; ', 'Content OK' );
+ }
+
+ #
+ # Belongs to the former test. This one goes for the action expecting two
+ # captures.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->multi_cap2
+ TestApp::Controller::Action::Chained->multi_cap_end2
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/multi_cap/1/2/baz'),
+ 'dispatch on capture num 2' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1, 2; ', 'Content OK' );
+ }
+
+ #
+ # Tests the priority of a slurpy arguments action (with :Args) against
+ # two actions chained together. The two actions should win.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->priority_a2
+ TestApp::Controller::Action::Chained->priority_a2_end
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/priority_a/1/end/2'),
+ 'priority - slurpy args vs. parent/child' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; 2', 'Content OK' );
+ }
+
+ #
+ # This belongs to the former test but tests if two chained actions have
+ # priority over an action with the exact arguments.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->priority_b2
+ TestApp::Controller::Action::Chained->priority_b2_end
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/priority_b/1/end/2'),
+ 'priority - fixed args vs. parent/child' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; 2', 'Content OK' );
+ }
+
+ #
+ # This belongs to the former test but tests if two chained actions have
+ # priority over an action with one child action not having the Args() attr set.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->priority_c1
+ TestApp::Controller::Action::Chained->priority_c2_xyz
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/priority_c/1/xyz/'),
+ 'priority - no Args() order mismatch' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; ', 'Content OK' );
+ }
+
+ #
+ # Test dispatching between two controllers that are on the same level and
+ # therefor have no parent/child relationship.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained::Bar->cross1
+ TestApp::Controller::Action::Chained::Foo->cross2
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/cross/1/end/2'),
+ 'cross controller w/o par/child relation' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; 2', 'Content OK' );
+ }
+
+ #
+ # This is for testing if the arguments got passed to the actions
+ # correctly.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained::PassedArgs->first
+ TestApp::Controller::Action::Chained::PassedArgs->second
+ TestApp::Controller::Action::Chained::PassedArgs->third
+ TestApp::Controller::Action::Chained::PassedArgs->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/passedargs/a/1/b/2/c/3'),
+ 'Correct arguments passed to actions' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; 2; 3', 'Content OK' );
+ }
+
+ #
+ # The :Args attribute is optional, we check the action not specifying
+ # it with these tests.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->opt_args
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/opt_args/1/2/3'),
+ 'Optional :Args attribute working' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '; 1, 2, 3', 'Content OK' );
+ }
+
+ #
+ # Tests for optional PathPart attribute.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->opt_pp_start
+ TestApp::Controller::Action::Chained->opt_pathpart
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/optpp/1/opt_pathpart/2'),
+ 'Optional :PathName attribute working' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; 2', 'Content OK' );
+ }
+
+ #
+ # Tests for optional PathPart *and* Args attributes.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->opt_all_start
+ TestApp::Controller::Action::Chained->oa
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/optall/1/oa/2/3'),
+ 'Optional :PathName *and* :Args attributes working' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; 2, 3', 'Content OK' );
+ }
+
+ #
+ # Test if :Chained is the same as :Chained('/')
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->rootdef
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/rootdef/23'),
+ ":Chained is the same as :Chained('/')" );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '; 23', 'Content OK' );
+ }
+
+ #
+ # Test if :Chained('.') is working
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->parentchain
+ TestApp::Controller::Action::Chained::ParentChain->child
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/parentchain/1/child/2'),
+ ":Chained('.') chains to parent controller action" );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; 2', 'Content OK' );
+ }
+
+ #
+ # Test behaviour of auto actions returning '1' for the chain.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained::Auto->auto
+ TestApp::Controller::Action::Chained::Auto::Foo->auto
+ TestApp::Controller::Action::Chained::Auto->foo
+ TestApp::Controller::Action::Chained::Auto::Foo->fooend
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/autochain1/1/fooend/2'),
+ "Behaviour when auto returns 1 correct" );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; 2', 'Content OK' );
+ }
+
+ #
+ # Test behaviour of auto actions returning '0' for the chain.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained::Auto->auto
+ TestApp::Controller::Action::Chained::Auto::Bar->auto
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/autochain2/1/barend/2'),
+ "Behaviour when auto returns 0 correct" );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; 2', 'Content OK' );
+ }
+
+ #
+ # Test what auto actions are run when namespaces are changed
+ # horizontally.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained::Auto->auto
+ TestApp::Controller::Action::Chained::Auto::Foo->auto
+ TestApp::Controller::Action::Chained::Auto::Bar->crossloose
+ TestApp::Controller::Action::Chained::Auto::Foo->crossend
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/auto_cross/1/crossend/2'),
+ "Correct auto actions are run on cross controller dispatch" );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; 2', 'Content OK' );
+ }
+
+ #
+ # Test forwarding from auto action in chain dispatch.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained::Auto->auto
+ TestApp::Controller::Action::Chained::Auto::Forward->auto
+ TestApp::Controller::Action::Chained::Auto->fw3
+ TestApp::Controller::Action::Chained::Auto->fw1
+ TestApp::Controller::Action::Chained::Auto::Forward->forwardend
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/auto_forward/1/forwardend/2'),
+ "Forwarding out of auto in chain" );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; 2', 'Content OK' );
+ }
+
+ #
+ # Detaching out of the auto action of a chain.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained::Auto->auto
+ TestApp::Controller::Action::Chained::Auto::Detach->auto
+ TestApp::Controller::Action::Chained::Auto->fw3
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/auto_detach/1/detachend/2'),
+ "Detaching out of auto in chain" );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; 2', 'Content OK' );
+ }
+
+ #
+ # Test forwarding from auto action in chain dispatch.
+ #
+ {
+ my $expected = undef;
+
+ ok( my $response = request('http://localhost/chained/loose/23'),
+ "Loose end is not callable" );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->code, 500, 'Status OK' );
+ }
+
+ #
+ # Test forwarding out of a chain.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->chain_fw_a
+ TestApp::Controller::Action::Chained->fw_dt_target
+ TestApp::Controller::Action::Chained->chain_fw_b
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/chain_fw/1/end/2'),
+ "Forwarding out a chain" );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; 2', 'Content OK' );
+ }
+
+ #
+ # Test detaching out of a chain.
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->chain_dt_a
+ TestApp::Controller::Action::Chained->fw_dt_target
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/chain_dt/1/end/2'),
+ "Forwarding out a chain" );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '1; 2', 'Content OK' );
+ }
+
+ #
+ # Tests that an uri_for to a chained root index action
+ # returns the right value.
+ #
+ {
+ ok( my $response = request(
+ 'http://localhost/action/chained/to_root' ),
+ 'uri_for with chained root action as arg' );
+ like( $response->content,
+ qr(URI:https?://[^/]+/),
+ 'Correct URI generated' );
+ }
+
+ #
+ # Test interception of recursive chains. This test was added because at
+ # one point during the :Chained development, Catalyst used to hang on
+ # recursive chains.
+ #
+ {
+ eval { require 'TestAppChainedRecursive.pm' };
+ if ($run_number == 1) {
+ ok( ! $@, "Interception of recursive chains" );
+ }
+ else { pass( "Interception of recursive chains already tested" ) }
+ }
+
+ #
+ # Test failure of absolute path part arguments.
+ #
+ {
+ eval { require 'TestAppChainedAbsolutePathPart.pm' };
+ if ($run_number == 1) {
+ like( $@, qr(foo/foo),
+ "Usage of absolute path part argument emits error" );
+ }
+ else { pass( "Error on absolute path part arguments already tested" ) }
+ }
+
+ #
+ # Test chained actions in the root controller
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained::Root->rootsub
+ TestApp::Controller::Action::Chained::Root->endpointsub
+ TestApp::Controller::Root->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/rootsub/1/endpointsub/2'), 'chained in root namespace' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '', 'Content OK' );
+ }
+
+ #
+ # Complex path with multiple empty pathparts
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->mult_nopp_base
+ TestApp::Controller::Action::Chained->mult_nopp_all
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/chained/mult_nopp'),
+ "Complex path with multiple empty pathparts" );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, '; ', 'Content OK' );
+ }
+
+ #
+ # Higher Args() hiding more specific CaptureArgs chains sections
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->cc_base
+ TestApp::Controller::Action::Chained->cc_link
+ TestApp::Controller::Action::Chained->cc_anchor
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join ', ', @expected;
+
+ ok( my $response = request('http://localhost/chained/choose_capture/anchor.html'),
+ 'Choose between an early Args() and a later more ideal chain' );
+ is( $response->header('X-Catalyst-Executed') => $expected, 'Executed actions');
+ is( $response->content => '; ', 'Content OK' );
+ }
+
+ #
+ # Less specific chain not being seen correctly due to earlier looser capture
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->cc_base
+ TestApp::Controller::Action::Chained->cc_b
+ TestApp::Controller::Action::Chained->cc_b_link
+ TestApp::Controller::Action::Chained->cc_b_anchor
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join ', ', @expected;
+
+ ok( my $response = request('http://localhost/chained/choose_capture/b/a/anchor.html'),
+ 'Choose between a more specific chain and an earlier looser one' );
+ is( $response->header('X-Catalyst-Executed') => $expected, 'Executed actions');
+ is( $response->content => 'a; ', 'Content OK' );
+ }
+
+ #
+ # Check we get the looser one when it's the correct match
+ #
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained->cc_base
+ TestApp::Controller::Action::Chained->cc_a
+ TestApp::Controller::Action::Chained->cc_a_link
+ TestApp::Controller::Action::Chained->cc_a_anchor
+ TestApp::Controller::Action::Chained->end
+ ];
+
+ my $expected = join ', ', @expected;
+
+ ok( my $response = request('http://localhost/chained/choose_capture/a/a/anchor.html'),
+ 'Choose between a more specific chain and an earlier looser one' );
+ is( $response->header('X-Catalyst-Executed') => $expected, 'Executed actions');
+ is( $response->content => 'a; anchor.html', 'Content OK' );
+ }
+
+}
@@ -0,0 +1,104 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 16 * $iters;
+use Catalyst::Test 'TestApp';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Default->begin
+ TestApp::Controller::Action::Default->default
+ TestApp::View::Dump::Request->process
+ TestApp::Controller::Root->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action/default'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'), 'default', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Default',
+ 'Test Class'
+ );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+
+ ok( $response = request('http://localhost/foo/bar/action'), 'Request' );
+ is( $response->code, 500, 'Invalid URI returned 500' );
+ }
+
+ # test that args are passed properly to default
+ {
+ my $creq;
+ my $expected = [qw/action default arg1 arg2/];
+
+ ok( my $response = request('http://localhost/action/default/arg1/arg2'),
+ 'Request' );
+ ok(
+ eval '$creq = ' . $response->content,
+ 'Unserialize Catalyst::Request'
+ );
+ is_deeply( $creq->{arguments}, $expected, 'Arguments ok' );
+ }
+
+
+ # Test that /foo and /foo/ both do the same thing
+ {
+ my @expected = qw[
+ TestApp::Controller::Action->begin
+ TestApp::Controller::Action->default
+ TestApp::Controller::Root->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action'), 'Request' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected,
+ 'Executed actions for /action'
+ );
+
+ ok( $response = request('http://localhost/action/'), 'Request' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected,
+ 'Executed actions for /action/'
+ );
+ }
+}
@@ -0,0 +1,108 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 18*$iters;
+use Catalyst::Test 'TestApp';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Detach->begin
+ TestApp::Controller::Action::Detach->one
+ TestApp::Controller::Action::Detach->two
+ TestApp::View::Dump::Request->process
+ TestApp::Controller::Root->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ # Test detach to chain of actions.
+ ok( my $response = request('http://localhost/action/detach/one'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action/detach/one', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Detach',
+ 'Test Class'
+ );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ }
+
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Detach->begin
+ TestApp::Controller::Action::Detach->path
+ TestApp::Controller::Action::Detach->two
+ TestApp::View::Dump::Request->process
+ TestApp::Controller::Root->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ # Test detach to chain of actions.
+ ok( my $response = request('http://localhost/action/detach/path'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action/detach/path', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Detach',
+ 'Test Class'
+ );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ }
+
+ {
+ ok(
+ my $response =
+ request('http://localhost/action/detach/with_args/old'),
+ 'Request with args'
+ );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content, 'new' );
+ }
+
+ {
+ ok(
+ my $response = request(
+ 'http://localhost/action/detach/with_method_and_args/old'),
+ 'Request with args and method'
+ );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content, 'new' );
+ }
+}
@@ -0,0 +1,62 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 7*$iters;
+use Catalyst::Test 'TestApp';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::End->begin
+ TestApp::Controller::Action::End->default
+ TestApp::View::Dump::Request->process
+ TestApp::Controller::Action::End->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action/end'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'), 'default', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::End',
+ 'Test Class'
+ );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+}
@@ -0,0 +1,246 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 47 * $iters;
+use Catalyst::Test 'TestApp';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Forward->begin
+ TestApp::Controller::Action::Forward->one
+ TestApp::Controller::Action::Forward->two
+ TestApp::Controller::Action::Forward->three
+ TestApp::Controller::Action::Forward->four
+ TestApp::Controller::Action::Forward->five
+ TestApp::View::Dump::Request->process
+ TestApp::Controller::Root->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ # Test forward to global private action
+ ok( my $response = request('http://localhost/action/forward/global'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action/forward/global', 'Main Class Action' );
+
+ # Test forward to chain of actions.
+ ok( $response = request('http://localhost/action/forward/one'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action/forward/one', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Forward',
+ 'Test Class'
+ );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Forward->begin
+ TestApp::Controller::Action::Forward->jojo
+ TestApp::Controller::Action::Forward->one
+ TestApp::Controller::Action::Forward->two
+ TestApp::Controller::Action::Forward->three
+ TestApp::Controller::Action::Forward->four
+ TestApp::Controller::Action::Forward->five
+ TestApp::View::Dump::Request->process
+ TestApp::Controller::Action::Forward->three
+ TestApp::Controller::Action::Forward->four
+ TestApp::Controller::Action::Forward->five
+ TestApp::View::Dump::Request->process
+ TestApp::Controller::Root->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action/forward/jojo'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action/forward/jojo', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Forward',
+ 'Test Class'
+ );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ ok(
+ my $response =
+ request('http://localhost/action/forward/with_args/old'),
+ 'Request with args'
+ );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content, 'old' );
+ }
+
+ {
+ ok(
+ my $response = request(
+ 'http://localhost/action/forward/with_method_and_args/old'),
+ 'Request with args and method'
+ );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content, 'old' );
+ }
+
+ # test forward with embedded args
+ {
+ ok(
+ my $response =
+ request('http://localhost/action/forward/args_embed_relative'),
+ 'Request'
+ );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content, 'ok' );
+ }
+
+ {
+ ok(
+ my $response =
+ request('http://localhost/action/forward/args_embed_absolute'),
+ 'Request'
+ );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content, 'ok' );
+ }
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::TestRelative->begin
+ TestApp::Controller::Action::TestRelative->relative
+ TestApp::Controller::Action::Forward->one
+ TestApp::Controller::Action::Forward->two
+ TestApp::Controller::Action::Forward->three
+ TestApp::Controller::Action::Forward->four
+ TestApp::Controller::Action::Forward->five
+ TestApp::View::Dump::Request->process
+ TestApp::Controller::Root->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ # Test forward to chain of actions.
+ ok( my $response = request('http://localhost/action/relative/relative'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action/relative/relative', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::TestRelative',
+ 'Test Class'
+ );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::TestRelative->begin
+ TestApp::Controller::Action::TestRelative->relative_two
+ TestApp::Controller::Action::Forward->one
+ TestApp::Controller::Action::Forward->two
+ TestApp::Controller::Action::Forward->three
+ TestApp::Controller::Action::Forward->four
+ TestApp::Controller::Action::Forward->five
+ TestApp::View::Dump::Request->process
+ TestApp::Controller::Root->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ # Test forward to chain of actions.
+ ok(
+ my $response =
+ request('http://localhost/action/relative/relative_two'),
+ 'Request'
+ );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is(
+ $response->header('X-Catalyst-Action'),
+ 'action/relative/relative_two',
+ 'Test Action'
+ );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::TestRelative',
+ 'Test Class'
+ );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ # test class forwards
+ {
+ ok(
+ my $response = request(
+ 'http://localhost/action/forward/class_forward_test_action'),
+ 'Request'
+ );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->header('X-Class-Forward-Test-Method'), 1,
+ 'Test Method' );
+ }
+
+}
@@ -0,0 +1,91 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 18*$iters;
+use Catalyst::Test 'TestApp';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+ {
+ ok( my $response = request('http://localhost/action_global_one'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action_global_one', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Global',
+ 'Test Class'
+ );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ ok( my $response = request('http://localhost/action_global_two'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action_global_two', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Global',
+ 'Test Class'
+ );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ ok( my $response = request('http://localhost/action_global_three'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action_global_three', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Global',
+ 'Test Class'
+ );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+}
@@ -0,0 +1,108 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 20*$iters;
+use Catalyst::Test 'TestApp';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+ # test root index
+ {
+ my @expected = qw[
+ TestApp::Controller::Root->index
+ TestApp::Controller::Root->end
+ ];
+
+ my $expected = join( ", ", @expected );
+ ok( my $response = request('http://localhost/'), 'root index' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, 'root index', 'root index ok' );
+
+ ok( $response = request('http://localhost'), 'root index no slash' );
+ is( $response->content, 'root index', 'root index no slash ok' );
+ }
+
+ # test first-level controller index
+ {
+ my @expected = qw[
+ TestApp::Controller::Index->index
+ TestApp::Controller::Root->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/index/'), 'first-level controller index' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, 'Index index', 'first-level controller index ok' );
+
+ ok( $response = request('http://localhost/index'), 'first-level controller index no slash' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, 'Index index', 'first-level controller index no slash ok' );
+ }
+
+ # test second-level controller index
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Index->begin
+ TestApp::Controller::Action::Index->index
+ TestApp::Controller::Root->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action/index/'), 'second-level controller index' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, 'Action-Index index', 'second-level controller index ok' );
+
+ ok( $response = request('http://localhost/action/index'), 'second-level controller index no slash' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, 'Action-Index index', 'second-level controller index no slash ok' );
+ }
+
+ # test controller default when index is present
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Index->begin
+ TestApp::Controller::Action::Index->default
+ TestApp::Controller::Root->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action/index/foo'), 'default with index' );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, "Error - TestApp::Controller::Action\n", 'default with index ok' );
+ }
+}
@@ -0,0 +1,127 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 21*$iters;
+use Catalyst::Test 'TestApp';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Inheritance->begin
+ TestApp::Controller::Action::Inheritance->auto
+ TestApp::Controller::Action::Inheritance->default
+ TestApp::View::Dump::Request->process
+ TestApp::Controller::Action::Inheritance->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action/inheritance'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'), 'default', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Inheritance',
+ 'Test Class'
+ );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Inheritance::A->begin
+ TestApp::Controller::Action::Inheritance->auto
+ TestApp::Controller::Action::Inheritance::A->auto
+ TestApp::Controller::Action::Inheritance::A->default
+ TestApp::View::Dump::Request->process
+ TestApp::Controller::Action::Inheritance::A->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action/inheritance/a'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'), 'default', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Inheritance::A',
+ 'Test Class'
+ );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Inheritance::A::B->begin
+ TestApp::Controller::Action::Inheritance->auto
+ TestApp::Controller::Action::Inheritance::A->auto
+ TestApp::Controller::Action::Inheritance::A::B->auto
+ TestApp::Controller::Action::Inheritance::A::B->default
+ TestApp::View::Dump::Request->process
+ TestApp::Controller::Action::Inheritance::A::B->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ ok( my $response = request('http://localhost/action/inheritance/a/b'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'), 'default', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Inheritance::A::B',
+ 'Test Class'
+ );
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+}
@@ -0,0 +1,146 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 32*$iters;
+use Catalyst::Test 'TestApp';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+ {
+ ok( my $response = request('http://localhost/action/local/one'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action/local/one', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Local',
+ 'Test Class'
+ );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ ok( my $response = request('http://localhost/action/local/two/1/2'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action/local/two', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Local',
+ 'Test Class'
+ );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ ok( my $response = request('http://localhost/action/local/two'),
+ 'Request' );
+ ok( !$response->is_success, 'Request with wrong number of args failed' );
+ }
+
+ {
+ ok( my $response = request('http://localhost/action/local/three'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action/local/three', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Local',
+ 'Test Class'
+ );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ ok(
+ my $response =
+ request('http://localhost/action/local/four/five/six'),
+ 'Request'
+ );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action/local/four/five/six', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Local',
+ 'Test Class'
+ );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ SKIP:
+ {
+ if ( $ENV{CATALYST_SERVER} ) {
+ skip "tests for %2F on remote server", 6;
+ }
+
+ ok(
+ my $response =
+ request('http://localhost/action/local/one/foo%2Fbar'),
+ 'Request'
+ );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action/local/one', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Local',
+ 'Test Class'
+ );
+ like(
+ $response->content,
+ qr~arguments => \[\s*'foo/bar'\s*\]~,
+ "Parameters don't split on %2F"
+ );
+ }
+}
@@ -0,0 +1,79 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+my $content = q/foo
+bar
+baz
+/;
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 16*$iters;
+use Catalyst::Test 'TestApp';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+ # Local
+ {
+ ok(
+ my $response =
+ request('http://localhost/action/multipath/multipath'),
+ 'Request'
+ );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->content, $content, 'Content is a stream' );
+ }
+
+ # Global
+ {
+ ok( my $response = request('http://localhost/multipath'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->content, $content, 'Content is a stream' );
+ }
+
+ # Path('/multipath1')
+ {
+ ok( my $response = request('http://localhost/multipath1'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->content, $content, 'Content is a stream' );
+ }
+
+ # Path('multipath2')
+ {
+ ok(
+ my $response =
+ request('http://localhost/action/multipath/multipath2'),
+ 'Request'
+ );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->content, $content, 'Content is a stream' );
+ }
+}
@@ -0,0 +1,135 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 30*$iters;
+use Catalyst::Test 'TestApp';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+ {
+ ok(
+ my $response =
+ request('http://localhost/action/path/a%20path%20with%20spaces'),
+ 'Request'
+ );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is(
+ $response->header('X-Catalyst-Action'),
+ 'action/path/a%20path%20with%20spaces',
+ 'Test Action'
+ );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Path',
+ 'Test Class'
+ );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ ok( my $response = request('http://localhost/action/path/åäö'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action/path/%C3%A5%C3%A4%C3%B6', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Path',
+ 'Test Class'
+ );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ ok( my $response = request('http://localhost/action/path/'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action/path', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Path',
+ 'Test Class'
+ );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ ok( my $response = request('http://localhost/action/path/spaces_near_parens_singleq'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action/path/spaces_near_parens_singleq', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Path',
+ 'Test Class'
+ );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ ok( my $response = request('http://localhost/action/path/spaces_near_parens_doubleq'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'action/path/spaces_near_parens_doubleq', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Path',
+ 'Test Class'
+ );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+}
@@ -0,0 +1,97 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 24*$iters;
+use Catalyst::Test 'TestApp';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+ {
+ ok( my $response = request('http://localhost/action/private/one'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Private',
+ 'Test Class'
+ );
+ is( $response->content, 'access denied', 'Access' );
+ }
+
+ {
+ ok( my $response = request('http://localhost/action/private/two'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Private',
+ 'Test Class'
+ );
+ is( $response->content, 'access denied', 'Access' );
+ }
+
+ {
+ ok( my $response = request('http://localhost/three'), 'Request' );
+ ok( $response->is_error, 'Response Server Error 5xx' );
+ is( $response->content_type, 'text/html', 'Response Content-Type' );
+ like(
+ $response->header('X-Catalyst-Error'),
+ qr/^Unknown resource "three"/,
+ 'Catalyst Error'
+ );
+ }
+
+ {
+ ok( my $response = request('http://localhost/action/private/four'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Private',
+ 'Test Class'
+ );
+ is( $response->content, 'access denied', 'Access' );
+ }
+
+ {
+ ok( my $response = request('http://localhost/action/private/five'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Private',
+ 'Test Class'
+ );
+ is( $response->content, 'access denied', 'Access' );
+ }
+}
@@ -0,0 +1,114 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 28*$iters;
+use Catalyst::Test 'TestApp';
+
+use Catalyst::Request;
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+ {
+ ok( my $response = request('http://localhost/action/regexp/10/hello'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ '^action/regexp/(\d+)/(\w+)$', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Regexp',
+ 'Test Class'
+ );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ ok( my $response = request('http://localhost/action/regexp/hello/10'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ '^action/regexp/(\w+)/(\d+)$', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Regexp',
+ 'Test Class'
+ );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ }
+
+ {
+ ok( my $response = request('http://localhost/action/regexp/mandatory'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ '^action/regexp/(mandatory)(/optional)?$', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Regexp',
+ 'Test Class'
+ );
+ my $content = $response->content;
+ my $req = eval $content;
+
+ is( scalar @{ $req->captures }, 2, 'number of captures' );
+ is( $req->captures->[ 0 ], 'mandatory', 'mandatory capture' );
+ ok( !defined $req->captures->[ 1 ], 'optional capture' );
+ }
+
+ {
+ ok( my $response = request('http://localhost/action/regexp/mandatory/optional'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ '^action/regexp/(mandatory)(/optional)?$', 'Test Action' );
+ is(
+ $response->header('X-Test-Class'),
+ 'TestApp::Controller::Action::Regexp',
+ 'Test Class'
+ );
+ my $content = $response->content;
+ my $req = eval $content;
+
+ is( scalar @{ $req->captures }, 2, 'number of captures' );
+ is( $req->captures->[ 0 ], 'mandatory', 'mandatory capture' );
+ is( $req->captures->[ 1 ], '/optional', 'optional capture' );
+ }
+}
@@ -0,0 +1,80 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
+
+use Test::More tests => 10*$iters;
+use Catalyst::Test 'TestApp';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+ # test direct streaming
+ {
+ ok( my $response = request('http://localhost/streaming'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+
+ SKIP:
+ {
+ if ( $ENV{CATALYST_SERVER} ) {
+ skip "Using remote server", 1;
+ }
+
+ # XXX: Length should be undef here, but HTTP::Request::AsCGI sets it
+ is( $response->content_length, 12, 'Response Content-Length' );
+ }
+
+ is( $response->content,, <<'EOF', 'Content is a stream' );
+foo
+bar
+baz
+EOF
+ }
+
+ # test streaming by passing a handle to $c->res->body
+ SKIP:
+ {
+ if ( $ENV{CATALYST_SERVER} ) {
+ skip "Using remote server", 5;
+ }
+
+ my $file = "$FindBin::Bin/lib/TestApp/Controller/Action/Streaming.pm";
+ my $fh = IO::File->new( $file, 'r' );
+ my $buffer;
+ if ( defined $fh ) {
+ $fh->read( $buffer, 1024 );
+ $fh->close;
+ }
+
+ ok( my $response = request('http://localhost/action/streaming/body'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->content_length, -s $file, 'Response Content-Length' );
+ is( $response->content, $buffer, 'Content is read from filehandle' );
+ }
+}
@@ -0,0 +1,105 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use URI::Escape;
+
+our @paths;
+our $iters;
+
+BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1;
+
+ # add special paths to test here
+ @paths = (
+ # all reserved in uri's
+ qw~ : / ? [ ] @ ! $ & ' ( ) * + ; = ~, ',' , '#',
+
+ # unreserved
+ 'a'..'z','A'..'Z',0..9,qw( - . _ ~ ),
+ " ",
+
+ # just to test %2F/%
+ [ qw~ / / ~ ],
+
+ # testing %25/%25
+ [ qw~ % % ~ ],
+ );
+}
+
+use Test::More tests => 6*@paths * $iters;
+use Catalyst::Test 'TestApp';
+
+if ( $ENV{CAT_BENCHMARK} ) {
+ require Benchmark;
+ Benchmark::timethis( $iters, \&run_tests );
+
+ # new dispatcher:
+ # 11 wallclock secs (10.14 usr + 0.20 sys = 10.34 CPU) @ 15.18/s (n=157)
+ # old dispatcher (r1486):
+ # 11 wallclock secs (10.34 usr + 0.20 sys = 10.54 CPU) @ 13.76/s (n=145)
+}
+else {
+ for ( 1 .. $iters ) {
+ run_tests();
+ }
+}
+
+sub run_tests {
+ run_test_for($_) for @paths;
+}
+
+sub run_test_for {
+ my $test = shift;
+
+ my $path;
+ if (ref $test) {
+ $path = join "/", map uri_escape($_), @$test;
+ $test = join '', @$test;
+ } else {
+ $path = uri_escape($test);
+ }
+
+ SKIP:
+ {
+ # Skip %2F, ., [, (, and ) tests on real webservers
+ # Both Apache and lighttpd don't seem to like these
+ if ( $ENV{CATALYST_SERVER} && $path =~ /(?:%2F|\.|%5B|\(|\))/ ) {
+ skip "Skipping $path tests on remote server", 6;
+ }
+
+ my $response;
+
+ ok( $response = request("http://localhost/args/args/$path"), "Requested args for path $path");
+
+ is( $response->content, $test, "$test as args" );
+
+ undef $response;
+
+ ok( $response = request("http://localhost/args/params/$path"), "Requested params for path $path");
+
+ is( $response->content, $test, "$test as params" );
+
+ undef $response;
+
+ if( $test =~ m{/} ) {
+ $test =~ s{/}{}g;
+ $path = uri_escape( $test );
+ }
+
+ ok( $response = request("http://localhost/chained/multi_cap/$path/baz"), "Requested capture for path $path");
+
+ is( $response->content, join( ', ', split( //, $test ) ) ."; ", "$test as capture" );
+ }
+}
@@ -0,0 +1,85 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 18;
+use Catalyst::Test 'TestApp';
+
+use Catalyst::Request;
+use HTTP::Headers;
+use HTTP::Request::Common;
+
+{
+ my $creq;
+
+ my $request = POST(
+ 'http://localhost/dump/request/',
+ 'Content-Type' => 'text/plain',
+ 'Content' => 'Hello Catalyst'
+ );
+
+ ok( my $response = request($request), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ like( $response->content, qr/'Catalyst::Request'/,
+ 'Content is a serialized Catalyst::Request' );
+
+ {
+ no strict 'refs';
+ ok(
+ eval '$creq = ' . $response->content,
+ 'Unserialize Catalyst::Request'
+ );
+ }
+
+ isa_ok( $creq, 'Catalyst::Request' );
+ is( $creq->method, 'POST', 'Catalyst::Request method' );
+ is( $creq->content_type, 'text/plain', 'Catalyst::Request Content-Type' );
+ is( $creq->content_length, $request->content_length,
+ 'Catalyst::Request Content-Length' );
+}
+
+{
+ my $creq;
+
+ my $request = POST(
+ 'http://localhost/dump/request/',
+ 'Content-Type' => 'text/plain',
+ 'Content' => 'x' x 100_000
+ );
+
+ ok( my $response = request($request), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+
+ {
+ no strict 'refs';
+ ok(
+ eval '$creq = ' . $response->content,
+ 'Unserialize Catalyst::Request'
+ );
+ }
+
+ isa_ok( $creq, 'Catalyst::Request' );
+ is( $creq->method, 'POST', 'Catalyst::Request method' );
+ is( $creq->content_type, 'text/plain', 'Catalyst::Request Content-Type' );
+ is( $creq->content_length, $request->content_length,
+ 'Catalyst::Request Content-Length' );
+}
@@ -0,0 +1,74 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 8;
+use Catalyst::Test 'TestAppOnDemand';
+
+use Catalyst::Request;
+use HTTP::Headers;
+use HTTP::Request::Common;
+
+# Test a simple POST request to make sure body parsing
+# works in on-demand mode.
+SKIP:
+{
+ if ( $ENV{CATALYST_SERVER} ) {
+ skip "Using remote server", 8;
+ }
+
+ {
+ my $params;
+
+ my $request = POST(
+ 'http://localhost/body/params',
+ 'Content-Type' => 'application/x-www-form-urlencoded',
+ 'Content' => 'foo=bar&baz=quux'
+ );
+
+ my $expected = { foo => 'bar', baz => 'quux' };
+
+ ok( my $response = request($request), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+
+ {
+ no strict 'refs';
+ ok(
+ eval '$params = ' . $response->content,
+ 'Unserialize params'
+ );
+ }
+
+ is_deeply( $params, $expected, 'Catalyst::Request body parameters' );
+ }
+
+ # Test reading chunks of the request body using $c->read
+ {
+ my $creq;
+
+ my $request = POST(
+ 'http://localhost/body/read',
+ 'Content-Type' => 'text/plain',
+ 'Content' => 'x' x 105_000
+ );
+
+ my $expected = '10000|10000|10000|10000|10000|10000|10000|10000|10000|10000|5000';
+
+ ok( my $response = request($request), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->content, $expected, 'Response Content' );
+ }
+}
@@ -0,0 +1,53 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 13;
+use Catalyst::Test 'TestApp';
+
+use Catalyst::Request;
+use CGI::Simple::Cookie;
+use HTTP::Headers;
+use HTTP::Request::Common;
+use URI;
+
+{
+ my $creq;
+
+ my $request = GET( 'http://localhost/dump/request',
+ 'Cookie' => 'Catalyst=Cool; Cool=Catalyst', );
+
+ ok( my $response = request($request), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ like( $response->content, qr/'Catalyst::Request'/,
+ 'Content is a serialized Catalyst::Request' );
+ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
+ isa_ok( $creq, 'Catalyst::Request' );
+ isa_ok( $creq->cookies->{Catalyst}, 'CGI::Simple::Cookie',
+ 'Cookie Catalyst' );
+ is( $creq->cookies->{Catalyst}->name, 'Catalyst', 'Cookie Catalyst name' );
+ is( $creq->cookies->{Catalyst}->value, 'Cool', 'Cookie Catalyst value' );
+ isa_ok( $creq->cookies->{Cool}, 'CGI::Simple::Cookie', 'Cookie Cool' );
+ is( $creq->cookies->{Cool}->name, 'Cool', 'Cookie Cool name' );
+ is( $creq->cookies->{Cool}->value, 'Catalyst', 'Cookie Cool value' );
+
+ my $cookies = {
+ Catalyst => $creq->cookies->{Catalyst},
+ Cool => $creq->cookies->{Cool}
+ };
+
+ is_deeply( $creq->cookies, $cookies, 'Cookies' );
+}
@@ -0,0 +1,79 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 17;
+use Catalyst::Test 'TestApp';
+
+use Catalyst::Request;
+use HTTP::Headers;
+use HTTP::Request::Common;
+
+{
+ my $creq;
+
+ my $request = GET( 'http://localhost/dump/request',
+ 'User-Agent' => 'MyAgen/1.0',
+ 'X-Whats-Cool' => 'Catalyst',
+ 'X-Multiple' => [ 1 .. 5 ],
+ 'X-Forwarded-Host' => 'frontend.server.com',
+ 'X-Forwarded-For' => '192.168.1.1, 1.2.3.4',
+ );
+
+ ok( my $response = request($request), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ like( $response->content, qr/^bless\( .* 'Catalyst::Request' \)$/s, 'Content is a serialized Catalyst::Request' );
+ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
+ isa_ok( $creq, 'Catalyst::Request' );
+ isa_ok( $creq->headers, 'HTTP::Headers', 'Catalyst::Request->headers' );
+ is( $creq->header('X-Whats-Cool'), $request->header('X-Whats-Cool'), 'Catalyst::Request->header X-Whats-Cool' );
+
+ { # Test that multiple headers are joined as per RFC 2616 4.2 and RFC 3875 4.1.18
+
+ my $excpected = '1, 2, 3, 4, 5';
+ my $got = $creq->header('X-Multiple'); # HTTP::Headers is context sensitive, "force" scalar context
+
+ is( $got, $excpected, 'Multiple message-headers are joined as a comma-separated list' );
+ }
+
+ is( $creq->header('User-Agent'), $request->header('User-Agent'), 'Catalyst::Request->header User-Agent' );
+
+ my $host = sprintf( '%s:%d', $request->uri->host, $request->uri->port );
+ is( $creq->header('Host'), $host, 'Catalyst::Request->header Host' );
+
+ SKIP:
+ {
+ if ( $ENV{CATALYST_SERVER} && $ENV{CATALYST_SERVER} !~ /127.0.0.1|localhost/ ) {
+ skip "Using remote server", 2;
+ }
+
+ is( $creq->base->host, 'frontend.server.com', 'Catalyst::Request proxied base' );
+ is( $creq->address, '1.2.3.4', 'Catalyst::Request proxied address' );
+ }
+
+ SKIP:
+ {
+ if ( $ENV{CATALYST_SERVER} ) {
+ skip "Using remote server", 4;
+ }
+ # test that we can ignore the proxy support
+ TestApp->config->{ignore_frontend_proxy} = 1;
+ ok( $response = request($request), 'Request' );
+ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
+ is( $creq->base, 'http://localhost/', 'Catalyst::Request non-proxied base' );
+ is( $creq->address, '127.0.0.1', 'Catalyst::Request non-proxied address' );
+ }
+}
@@ -0,0 +1,137 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 35;
+use Catalyst::Test 'TestApp';
+
+use Catalyst::Request;
+use HTTP::Headers;
+use HTTP::Request::Common;
+
+{
+ my $creq;
+
+ my $parameters = { 'a' => [qw(A b C d E f G)], };
+
+ my $query = join( '&', map { 'a=' . $_ } @{ $parameters->{a} } );
+
+ ok( my $response = request("http://localhost/dump/request?$query"),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
+ isa_ok( $creq, 'Catalyst::Request' );
+ is( $creq->method, 'GET', 'Catalyst::Request method' );
+ is_deeply( $creq->{parameters}, $parameters,
+ 'Catalyst::Request parameters' );
+}
+
+{
+ my $creq;
+ ok( my $response = request("http://localhost/dump/request?q=foo%2bbar"),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ ok( eval '$creq = ' . $response->content );
+ is $creq->{parameters}->{q}, 'foo+bar', '%2b not double decoded';
+}
+
+{
+ my $creq;
+
+ my $parameters = {
+ 'a' => [qw(A b C d E f G)],
+ '%' => [ '%', '"', '& - &' ],
+ 'blank' => '',
+ };
+
+ my $request = POST(
+ 'http://localhost/dump/request/a/b?a=1&a=2&a=3',
+ 'Content' => $parameters,
+ 'Content-Type' => 'application/x-www-form-urlencoded'
+ );
+
+ unshift( @{ $parameters->{a} }, 1, 2, 3 );
+
+ ok( my $response = request($request), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
+ isa_ok( $creq, 'Catalyst::Request' );
+ is( $creq->method, 'POST', 'Catalyst::Request method' );
+ is_deeply( $creq->{parameters}, $parameters,
+ 'Catalyst::Request parameters' );
+ is_deeply( $creq->arguments, [qw(a b)], 'Catalyst::Request arguments' );
+ is_deeply( $creq->{uploads}, {}, 'Catalyst::Request uploads' );
+ is_deeply( $creq->cookies, {}, 'Catalyst::Request cookie' );
+}
+
+# http://dev.catalyst.perl.org/ticket/37
+# multipart/form-data parameters that contain 'http://'
+# was an HTTP::Message bug, but HTTP::Body handles it properly now
+{
+ my $creq;
+
+ my $parameters = {
+ 'url' => 'http://www.google.com',
+ 'blank' => '',
+ };
+
+ my $request = POST( 'http://localhost/dump/request',
+ 'Content-Type' => 'multipart/form-data',
+ 'Content' => $parameters,
+ );
+
+ ok( my $response = request($request), 'Request' );
+ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
+ is_deeply( $creq->{parameters}, $parameters, 'Catalyst::Request parameters' );
+}
+
+# raw query string support
+{
+ my $creq;
+
+ my $parameters = {
+ a => 1,
+ blank => '',
+ };
+
+ my $request = POST(
+ 'http://localhost/dump/request/a/b?query+string',
+ 'Content' => $parameters,
+ 'Content-Type' => 'application/x-www-form-urlencoded'
+ );
+
+ ok( my $response = request($request), 'Request' );
+ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
+ is( $creq->{uri}->query, 'query+string', 'Catalyst::Request POST query_string' );
+ is( $creq->query_keywords, 'query string', 'Catalyst::Request query_keywords' );
+ is_deeply( $creq->{parameters}, $parameters, 'Catalyst::Request parameters' );
+
+ ok( $response = request('http://localhost/dump/request/a/b?x=1&y=1&z=1'), 'Request' );
+ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
+ is( $creq->{uri}->query, 'x=1&y=1&z=1', 'Catalyst::Request GET query_string' );
+}
@@ -0,0 +1,254 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More;
+use Catalyst::Test 'TestApp';
+
+use Catalyst::Request;
+use Catalyst::Request::Upload;
+use HTTP::Headers;
+use HTTP::Headers::Util 'split_header_words';
+use HTTP::Request::Common;
+
+{
+ my $creq;
+
+ my $request = POST(
+ 'http://localhost/dump/request/',
+ 'Content-Type' => 'form-data',
+ 'Content' => [
+ 'author-live_engine_request_cookies.t' =>
+ ["$FindBin::Bin/author-live_engine_request_cookies.t"],
+ 'author-live_engine_request_headers.t' =>
+ ["$FindBin::Bin/author-live_engine_request_headers.t"],
+ 'author-live_engine_request_uploads.t' =>
+ ["$FindBin::Bin/author-live_engine_request_uploads.t"],
+ ]
+ );
+
+ ok( my $response = request($request), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+
+ {
+ no strict 'refs';
+ ok(
+ eval '$creq = ' . $response->content,
+ 'Unserialize Catalyst::Request'
+ );
+ }
+
+ isa_ok( $creq, 'Catalyst::Request' );
+ is( $creq->method, 'POST', 'Catalyst::Request method' );
+ is( $creq->content_type, 'multipart/form-data',
+ 'Catalyst::Request Content-Type' );
+ is( $creq->content_length, $request->content_length,
+ 'Catalyst::Request Content-Length' );
+
+ for my $part ( $request->parts ) {
+
+ my $disposition = $part->header('Content-Disposition');
+ my %parameters = @{ ( split_header_words($disposition) )[0] };
+
+ my $upload = $creq->{uploads}->{ $parameters{filename} };
+
+ isa_ok( $upload, 'Catalyst::Request::Upload' );
+
+ is( $upload->type, $part->content_type, 'Upload Content-Type' );
+ is( $upload->size, length( $part->content ), 'Upload Content-Length' );
+
+ # make sure upload is accessible via legacy params->{$file}
+ is( $creq->{parameters}->{ $upload->filename },
+ $upload->filename, 'legacy param method ok' );
+
+ ok( !-e $upload->tempname, 'Upload temp file was deleted' );
+ }
+}
+
+{
+ my $creq;
+
+ my $request = POST(
+ 'http://localhost/dump/request/',
+ 'Content-Type' => 'multipart/form-data',
+ 'Content' => [
+ 'testfile' => ["$FindBin::Bin/author-live_engine_request_cookies.t"],
+ 'testfile' => ["$FindBin::Bin/author-live_engine_request_headers.t"],
+ 'testfile' => ["$FindBin::Bin/author-live_engine_request_uploads.t"],
+ ]
+ );
+
+ ok( my $response = request($request), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+
+ {
+ no strict 'refs';
+ ok(
+ eval '$creq = ' . $response->content,
+ 'Unserialize Catalyst::Request'
+ );
+ }
+
+ isa_ok( $creq, 'Catalyst::Request' );
+ is( $creq->method, 'POST', 'Catalyst::Request method' );
+ is( $creq->content_type, 'multipart/form-data',
+ 'Catalyst::Request Content-Type' );
+ is( $creq->content_length, $request->content_length,
+ 'Catalyst::Request Content-Length' );
+
+ my @parts = $request->parts;
+
+ for ( my $i = 0 ; $i < @parts ; $i++ ) {
+
+ my $part = $parts[$i];
+ my $disposition = $part->header('Content-Disposition');
+ my %parameters = @{ ( split_header_words($disposition) )[0] };
+
+ my $upload = $creq->{uploads}->{ $parameters{name} }->[$i];
+
+ isa_ok( $upload, 'Catalyst::Request::Upload' );
+ is( $upload->type, $part->content_type, 'Upload Content-Type' );
+ is( $upload->filename, $parameters{filename}, 'Upload filename' );
+ is( $upload->size, length( $part->content ), 'Upload Content-Length' );
+
+ ok( !-e $upload->tempname, 'Upload temp file was deleted' );
+ }
+}
+
+{
+ my $creq;
+
+ my $request = POST(
+ 'http://localhost/engine/request/uploads/slurp',
+ 'Content-Type' => 'multipart/form-data',
+ 'Content' =>
+ [ 'slurp' => ["$FindBin::Bin/author-live_engine_request_uploads.t"], ]
+ );
+
+ ok( my $response = request($request), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->content, ( $request->parts )[0]->content, 'Content' );
+}
+
+{
+ my $request = POST(
+ 'http://localhost/dump/request',
+ 'Content-Type' => 'multipart/form-data',
+ 'Content' =>
+ [ 'file' => ["$FindBin::Bin/catalyst_130pix.gif"], ]
+ );
+
+ # LWP will auto-correct Content-Length when using a remote server
+ SKIP:
+ {
+ if ( $ENV{CATALYST_SERVER} ) {
+ skip 'Using remote server', 2;
+ }
+
+ # Sending wrong Content-Length here and see if subequent requests fail
+ $request->header('Content-Length' => $request->header('Content-Length') + 1);
+
+ ok( my $response = request($request), 'Request' );
+ ok( !$response->is_success, 'Response Error' );
+ }
+
+ $request = POST(
+ 'http://localhost/dump/request',
+ 'Content-Type' => 'multipart/form-data',
+ 'Content' =>
+ [ 'file1' => ["$FindBin::Bin/catalyst_130pix.gif"],
+ 'file2' => ["$FindBin::Bin/catalyst_130pix.gif"], ]
+ );
+
+ ok( my $response = request($request), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ like( $response->content, qr/file1 => bless/, 'Upload with name file1');
+ like( $response->content, qr/file2 => bless/, 'Upload with name file2');
+}
+
+{
+ my $creq;
+
+ my $request = POST(
+ 'http://localhost/dump/request/',
+ 'Content-Type' => 'form-data',
+ 'Content' => [
+ 'testfile' => 'textfield value',
+ 'testfile' => ["$FindBin::Bin/catalyst_130pix.gif"],
+ ]
+ );
+
+ ok( my $response = request($request), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ like(
+ $response->content,
+ qr/^bless\( .* 'Catalyst::Request' \)$/s,
+ 'Content is a serialized Catalyst::Request'
+ );
+
+ {
+ no strict 'refs';
+ ok(
+ eval '$creq = ' . $response->content,
+ 'Unserialize Catalyst::Request'
+ );
+ }
+
+ isa_ok( $creq, 'Catalyst::Request' );
+ is( $creq->method, 'POST', 'Catalyst::Request method' );
+ is( $creq->content_type, 'multipart/form-data',
+ 'Catalyst::Request Content-Type' );
+ is( $creq->content_length, $request->content_length,
+ 'Catalyst::Request Content-Length' );
+
+ my $param = $creq->{parameters}->{testfile};
+
+ ok( @$param == 2, '2 values' );
+ is( $param->[0], 'textfield value', 'correct value' );
+ like( $param->[1], qr/\Qcatalyst_130pix.gif/, 'filename' );
+
+ for my $part ( $request->parts ) {
+
+ my $disposition = $part->header('Content-Disposition');
+ my %parameters = @{ ( split_header_words($disposition) )[0] };
+
+ next unless exists $parameters{filename};
+
+ my $upload = $creq->{uploads}->{ $parameters{name} };
+
+ isa_ok( $upload, 'Catalyst::Request::Upload' );
+
+ is( $upload->type, $part->content_type, 'Upload Content-Type' );
+ is( $upload->size, length( $part->content ), 'Upload Content-Length' );
+ is( $upload->filename, 'catalyst_130pix.gif' );
+ }
+}
+
+done_testing;
@@ -0,0 +1,129 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 49;
+use Catalyst::Test 'TestApp';
+use Catalyst::Request;
+
+my $creq;
+
+# test that the path can be changed
+{
+ ok( my $response = request('http://localhost/engine/request/uri/change_path'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
+ like( $creq->uri, qr{/my/app/lives/here$}, 'URI contains new path' );
+}
+
+# test that path properly removes the base location
+{
+ ok( my $response = request('http://localhost/engine/request/uri/change_base'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
+ like( $creq->base, qr{/new/location}, 'Base URI contains new location' );
+ is( $creq->path, 'engine/request/uri/change_base', 'URI contains correct path' );
+}
+
+# test that base + path is correct
+{
+ ok( my $response = request('http://localhost/engine/request/uri'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
+ is( $creq->base . $creq->path, $creq->uri, 'Base + Path ok' );
+}
+
+# test base is correct for HTTPS URLs
+SKIP:
+{
+ if ( $ENV{CATALYST_SERVER} ) {
+ skip 'Using remote server', 5;
+ }
+
+ local $ENV{HTTPS} = 'on';
+ ok( my $response = request('https://localhost/engine/request/uri'), 'HTTPS Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
+ is( $creq->base, 'https://localhost/', 'HTTPS base ok' );
+ is( $creq->uri, 'https://localhost/engine/request/uri', 'HTTPS uri ok' );
+}
+
+# test that we can use semi-colons as separators
+{
+ my $parameters = {
+ a => [ qw/1 2/ ],
+ b => 3,
+ };
+
+ ok( my $response = request('http://localhost/engine/request/uri?a=1;a=2;b=3'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
+ is( $creq->{uri}->query, 'a=1;a=2;b=3', 'Query string ok' );
+ is_deeply( $creq->{parameters}, $parameters, 'Parameters ok' );
+}
+
+# test that query params are unescaped properly
+{
+ ok( my $response = request('http://localhost/engine/request/uri?text=Catalyst%20Rocks'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
+ is( $creq->{uri}->query, 'text=Catalyst%20Rocks', 'Query string ok' );
+ is( $creq->{parameters}->{text}, 'Catalyst Rocks', 'Unescaped param ok' );
+}
+
+# test that uri_with adds params
+{
+ ok( my $response = request('http://localhost/engine/request/uri/uri_with'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ ok( !defined $response->header( 'X-Catalyst-Param-a' ), 'param "a" ok' );
+ is( $response->header( 'X-Catalyst-Param-b' ), '1', 'param "b" ok' );
+}
+
+# test that uri_with adds params (and preserves)
+{
+ ok( my $response = request('http://localhost/engine/request/uri/uri_with?a=1'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->header( 'X-Catalyst-Param-a' ), '1', 'param "a" ok' );
+ is( $response->header( 'X-Catalyst-Param-b' ), '1', 'param "b" ok' );
+}
+
+# test that uri_with replaces params (and preserves)
+{
+ ok( my $response = request('http://localhost/engine/request/uri/uri_with?a=1&b=2'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->header( 'X-Catalyst-Param-a' ), '1', 'param "a" ok' );
+ is( $response->header( 'X-Catalyst-Param-b' ), '1', 'param "b" ok' );
+}
+
+# test that uri_with replaces params (and preserves)
+{
+ ok( my $response = request('http://localhost/engine/request/uri/uri_with_object'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ like( $response->header( 'X-Catalyst-Param-a' ), qr(https?://localhost[^/]*/), 'param "a" ok' );
+}
+
+# test that uri_with is utf8 safe
+{
+ ok( my $response = request("http://localhost/engine/request/uri/uri_with_utf8"), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ like( $response->header( 'X-Catalyst-uri-with' ), qr/%E2%98%A0$/, 'uri_with ok' );
+}
+
+# test with undef -- no warnings should be thrown
+{
+ ok( my $response = request("http://localhost/engine/request/uri/uri_with_undef"), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->header( 'X-Catalyst-warnings' ), 0, 'no warnings emitted' );
+}
@@ -0,0 +1,81 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 15;
+use Catalyst::Test 'TestApp';
+use HTTP::Headers::Util 'split_header_words';
+
+my $expected = {
+ catalyst => [qw|catalyst cool path /bah|],
+ cool => [qw|cool catalyst path /|]
+};
+
+{
+ ok( my $response = request('http://localhost/engine/response/cookies/one'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'engine/response/cookies/one', 'Test Action' );
+
+ my $cookies = {};
+
+ for my $string ( $response->header('Set-Cookie') ) {
+ my $cookie = [ split_header_words $string];
+ $cookies->{ $cookie->[0]->[0] } = $cookie->[0];
+ }
+
+ is_deeply( $cookies, $expected, 'Response Cookies' );
+}
+
+{
+ ok( my $response = request('http://localhost/engine/response/cookies/two'),
+ 'Request' );
+ ok( $response->is_redirect, 'Response Redirection 3xx' );
+ is( $response->code, 302, 'Response Code' );
+ is( $response->header('X-Catalyst-Action'),
+ 'engine/response/cookies/two', 'Test Action' );
+
+ my $cookies = {};
+
+ for my $string ( $response->header('Set-Cookie') ) {
+ my $cookie = [ split_header_words $string];
+ $cookies->{ $cookie->[0]->[0] } = $cookie->[0];
+ }
+
+ is_deeply( $cookies, $expected, 'Response Cookies' );
+}
+
+{
+ ok( my $response = request('http://localhost/engine/response/cookies/three'),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'engine/response/cookies/three', 'Test Action' );
+
+ my $cookies = {};
+
+ for my $string ( $response->header('Set-Cookie') ) {
+ my $cookie = [ split_header_words $string];
+ $cookies->{ $cookie->[0]->[0] } = $cookie->[0];
+ }
+
+ is_deeply( $cookies, {
+ hash => [ qw(hash a&b&c path /) ],
+ this_is_the_real_name => [ qw(this_is_the_real_name foo&bar path /) ], # not "object"
+ }, 'Response Cookies' );
+}
@@ -0,0 +1,68 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 18;
+use Catalyst::Test 'TestApp';
+
+close STDERR; # i'm naughty :)
+
+{
+ ok( my $response = request('http://localhost/engine/response/errors/one'),
+ 'Request' );
+ ok( $response->is_error, 'Response Server Error 5xx' );
+ is( $response->code, 500, 'Response Code' );
+ is( $response->content_type, 'text/html', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'engine/response/errors/one', 'Test Action' );
+ like(
+ $response->header('X-Catalyst-Error'),
+ qr/^Caught exception/,
+ 'Catalyst Error'
+ );
+}
+
+{
+ ok( my $response = request('http://localhost/engine/response/errors/two'),
+ 'Request' );
+ ok( $response->is_error, 'Response Server Error 5xx' );
+ is( $response->code, 500, 'Response Code' );
+ is( $response->content_type, 'text/html', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'),
+ 'engine/response/errors/two', 'Test Action' );
+ like(
+ $response->header('X-Catalyst-Error'),
+ qr/^Couldn't forward to/,
+ 'Catalyst Error'
+ );
+}
+
+{
+ ok( my $response = request('http://localhost/engine/response/errors/three'),
+ 'Request' );
+ ok( $response->is_error, 'Response Server Error 5xx' );
+ is( $response->code, 500, 'Response Code' );
+ is( $response->content_type, 'text/html', 'Response Content-Type' );
+ is(
+ $response->header('X-Catalyst-Action'),
+ 'engine/response/errors/three',
+ 'Test Action'
+ );
+ like(
+ $response->header('X-Catalyst-Error'),
+ qr/I'm going to die!/,
+ 'Catalyst Error'
+ );
+}
@@ -0,0 +1,66 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 18;
+use Catalyst::Test 'TestApp';
+use HTTP::Request::Common;
+
+my $content_length;
+
+foreach my $method qw(HEAD GET) {
+ my $expected = join( ', ', 1 .. 10 );
+
+ my $request = HTTP::Request::Common->can($method)
+ ->( 'http://localhost/engine/response/headers/one' );
+
+ ok( my $response = request($request), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->code, 200, 'Response Code' );
+ is( $response->header('X-Catalyst-Action'),
+ 'engine/response/headers/one', 'Test Action' );
+ is( $response->header('X-Header-Catalyst'),
+ 'Cool', 'Response Header X-Header-Catalyst' );
+ is( $response->header('X-Header-Cool'),
+ 'Catalyst', 'Response Header X-Header-Cool' );
+ is( $response->header('X-Header-Numbers'),
+ $expected, 'Response Header X-Header-Numbers' );
+
+ use bytes;
+ if ( $method eq 'HEAD' ) {
+ $content_length = $response->header('Content-Length');
+ ok( $content_length > 0, 'Response Header Content-Length' );
+ is( length($response->content),
+ 0,
+ 'HEAD method content is empty' );
+ }
+ elsif ( $method eq 'GET' ) {
+ # method name is echo'd back in content-body, which
+ # accounts for difference in content length. In normal
+ # cases the Content-Length should be the same regardless
+ # of if its a GET or HEAD request.
+ SKIP:
+ {
+ if ( $ENV{CATALYST_SERVER} ) {
+ skip "Using remote server", 2;
+ }
+ is( $response->header('Content-Length'),
+ $content_length - 1, 'Response Header Content-Length' );
+ is( length($response->content),
+ $response->header('Content-Length'),
+ 'GET method content' );
+ }
+ }
+}
@@ -0,0 +1,34 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 6;
+use Catalyst::Test 'TestApp';
+
+# phaylon noticed that refactored was truncating output on large images.
+# This test tests 100K and 1M output content.
+
+my $expected = {
+ one => 'x' x (100 * 1024),
+ two => 'y' x (1024 * 1024),
+};
+
+for my $action ( keys %{$expected} ) {
+ ok( my $response = request('http://localhost/engine/response/large/' . $action ),
+ 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+
+ is( length( $response->content ), length( $expected->{$action} ), 'Length OK' );
+}
@@ -0,0 +1,56 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 26;
+use Catalyst::Test 'TestApp';
+
+{
+ ok( my $response = request('http://localhost/engine/response/redirect/one'), 'Request' );
+ ok( $response->is_redirect, 'Response Redirection 3xx' );
+ is( $response->code, 302, 'Response Code' );
+ is( $response->header('X-Catalyst-Action'), 'engine/response/redirect/one', 'Test Action' );
+ is( $response->header('Location'), '/test/writing/is/boring', 'Response Header Location' );
+ ok( $response->header('Content-Length'), '302 Redirect contains Content-Length' );
+ ok( $response->content, '302 Redirect contains a response body' );
+}
+
+{
+ ok( my $response = request('http://localhost/engine/response/redirect/two'), 'Request' );
+ ok( $response->is_redirect, 'Response Redirection 3xx' );
+ is( $response->code, 302, 'Response Code' );
+ is( $response->header('X-Catalyst-Action'), 'engine/response/redirect/two', 'Test Action' );
+ is( $response->header('Location'), 'http://www.google.com/', 'Response Header Location' );
+}
+
+{
+ ok( my $response = request('http://localhost/engine/response/redirect/three'), 'Request' );
+ ok( $response->is_redirect, 'Response Redirection 3xx' );
+ is( $response->code, 301, 'Response Code' );
+ is( $response->header('X-Catalyst-Action'), 'engine/response/redirect/three', 'Test Action' );
+ is( $response->header('Location'), 'http://www.google.com/', 'Response Header Location' );
+ ok( $response->header('Content-Length'), '301 Redirect contains Content-Length' );
+ ok( $response->content, '301 Redirect contains a response body' );
+}
+
+{
+ ok( my $response = request('http://localhost/engine/response/redirect/four'), 'Request' );
+ ok( $response->is_redirect, 'Response Redirection 3xx' );
+ is( $response->code, 307, 'Response Code' );
+ is( $response->header('X-Catalyst-Action'), 'engine/response/redirect/four', 'Test Action' );
+ is( $response->header('Location'), 'http://www.google.com/', 'Response Header Location' );
+ ok( $response->header('Content-Length'), '307 Redirect contains Content-Length' );
+ ok( $response->content, '307 Redirect contains a response body' );
+}
@@ -0,0 +1,63 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 30;
+use Catalyst::Test 'TestApp';
+
+{
+ ok( my $response = request('http://localhost/engine/response/status/s200'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ is( $response->code, 200, 'Response Code' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'), 'engine/response/status/s200', 'Test Action' );
+ like( $response->content, qr/^200/, 'Response Content' );
+}
+
+{
+ ok( my $response = request('http://localhost/engine/response/status/s400'), 'Request' );
+ ok( $response->is_error, 'Response Client Error 4xx' );
+ is( $response->code, 400, 'Response Code' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'), 'engine/response/status/s400', 'Test Action' );
+ like( $response->content, qr/^400/, 'Response Content' );
+}
+
+{
+ ok( my $response = request('http://localhost/engine/response/status/s403'), 'Request' );
+ ok( $response->is_error, 'Response Client Error 4xx' );
+ is( $response->code, 403, 'Response Code' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'), 'engine/response/status/s403', 'Test Action' );
+ like( $response->content, qr/^403/, 'Response Content' );
+}
+
+{
+ ok( my $response = request('http://localhost/engine/response/status/s404'), 'Request' );
+ ok( $response->is_error, 'Response Client Error 4xx' );
+ is( $response->code, 404, 'Response Code' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'), 'engine/response/status/s404', 'Test Action' );
+ like( $response->content, qr/^404/, 'Response Content' );
+}
+
+{
+ ok( my $response = request('http://localhost/engine/response/status/s500'), 'Request' );
+ ok( $response->is_error, 'Response Server Error 5xx' );
+ is( $response->code, 500, 'Response Code' );
+ is( $response->content_type, 'text/plain', 'Response Content-Type' );
+ is( $response->header('X-Catalyst-Action'), 'engine/response/status/s500', 'Test Action' );
+ like( $response->content, qr/^500/, 'Response Content' );
+}
@@ -0,0 +1,27 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 1;
+use Catalyst::Test 'TestApp';
+
+SKIP:
+{
+ if ( $ENV{CATALYST_SERVER} ) {
+ skip "Using remote server", 1;
+ }
+ # Allow overriding automatic root.
+ is( TestApp->config->{root}, '/some/dir' );
+}
@@ -0,0 +1,24 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 2;
+use Catalyst::Test 'TestApp';
+
+{
+ # Allow overriding automatic root.
+ ok( my $response = request('http://localhost/engine/response/headers/one'), 'Request' );
+ is( $response->header('X-Catalyst-Plugin-Setup'), '1' );
+}
@@ -0,0 +1,68 @@
+#!/usr/bin/perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+# live_fork.t
+# Copyright (c) 2006 Jonathan Rockway <jrockway@cpan.org>
+
+=head1 SYNOPSIS
+
+Tests if Catalyst can fork/exec other processes successfully
+
+=cut
+use strict;
+use warnings;
+use Test::More;
+use YAML;
+use FindBin;
+use lib "$FindBin::Bin/lib";
+use Catalyst::Test qw(TestApp);
+
+plan skip_all => 'Using remote server'
+ if $ENV{CATALYST_SERVER};
+
+plan skip_all => 'Skipping fork tests: no /bin/ls'
+ if !-e '/bin/ls'; # see if /bin/ls exists
+
+plan tests => 13; # otherwise
+
+{
+ system:
+ ok(my $result = get('/fork/system/%2Fbin%2Fls'), 'system');
+ my @result = split /$/m, $result;
+ $result = join q{}, @result[-4..-1];
+
+ my $result_ref = eval { Load($result) };
+ ok($result_ref, 'is YAML');
+ is($result_ref->{result}, 0, 'exited OK');
+}
+
+{
+ backticks:
+ ok(my $result = get('/fork/backticks/%2Fbin%2Fls'), '`backticks`');
+ my @result = split /$/m, $result;
+ $result = join q{}, @result[-4..-1];
+
+ my $result_ref = eval { Load($result) };
+ ok($result_ref, 'is YAML');
+ is($result_ref->{code}, 0, 'exited successfully');
+ like($result_ref->{result}, qr{^/bin/ls[^:]}, 'contains ^/bin/ls$');
+ like($result_ref->{result}, qr{\n.*\n}m, 'contains two newlines');
+}
+{
+ fork:
+ ok(my $result = get('/fork/fork'), 'fork');
+ my @result = split /$/m, $result;
+ $result = join q{}, @result[-4..-1];
+
+ my $result_ref = eval { Load($result) };
+ ok($result_ref, 'is YAML');
+ isnt($result_ref->{pid}, 0, q{fork's "pid" wasn't 0});
+ isnt($result_ref->{pid}, $$, 'fork got a new pid');
+ is($result_ref->{result}, 'ok', 'fork was effective');
+}
@@ -0,0 +1,31 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 3;
+use Catalyst::Test 'TestApp';
+
+SKIP:
+{
+ # Net::HTTP::Methods crashes when talking to a remote server because this
+ # test causes a very long header line to be sent
+ if ( $ENV{CATALYST_SERVER} ) {
+ skip 'Using remote server', 3;
+ }
+
+ ok( my $response = request('http://localhost/loop_test'), 'Request' );
+ ok( $response->is_success, 'Response Successful 2xx' );
+ ok( $response->header('X-Class-Forward-Test-Method'), 'Loop OK' );
+}
@@ -0,0 +1,31 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 5;
+use Catalyst::Test 'TestApp';
+
+my @expected = qw[
+ Catalyst::Plugin::Test::Errors Catalyst::Plugin::Test::Headers Catalyst::Plugin::Test::Inline Catalyst::Plugin::Test::MangleDollarUnderScore Catalyst::Plugin::Test::Plugin TestApp::Plugin::AddDispatchTypes TestApp::Plugin::FullyQualified
+];
+
+my $expected = join( ", ", @expected );
+
+ok( my $response = request('http://localhost/dump/request'), 'Request' );
+ok( $response->is_success, 'Response Successful 2xx' );
+is( $response->content_type, 'text/plain', 'Response Content-Type' );
+like( $response->content, qr/'Catalyst::Request'/,
+ 'Content is a serialized Catalyst::Request' );
+is( $response->header('X-Catalyst-Plugins'), $expected, 'Loaded plugins' );
@@ -0,0 +1,88 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 28;
+use Catalyst::Test 'TestApp';
+use Data::Dumper;
+
+local $^W = 0;
+
+my $uri_base = 'http://localhost/priorities';
+my @tests = (
+
+ # Simple
+ 'Regex vs. Local', { path => '/re_vs_loc', expect => 'local' },
+ 'Regex vs. LocalRegex', { path => '/re_vs_locre', expect => 'regex' },
+ 'Regex vs. Path', { path => '/re_vs_path', expect => 'path' },
+ 'Local vs. LocalRegex', { path => '/loc_vs_locre', expect => 'local' },
+ 'Local vs. Path 1', { path => '/loc_vs_path1', expect => 'local' },
+ 'Local vs. Path 2', { path => '/loc_vs_path2', expect => 'path' },
+ 'Path vs. LocalRegex', { path => '/path_vs_locre', expect => 'path' },
+
+ # index
+ 'index vs. Regex', { path => '/re_vs_index', expect => 'index' },
+ 'index vs. Local', { path => '/loc_vs_index', expect => 'index' },
+ 'index vs. LocalRegex', { path => '/locre_vs_index', expect => 'index' },
+ 'index vs. Path', { path => '/path_vs_index', expect => 'index' },
+
+ 'multimethod zero', { path => '/multimethod', expect => 'zero' },
+ 'multimethod one', { path => '/multimethod/1', expect => 'one 1' },
+ 'multimethod two', { path => '/multimethod/1/2',
+ expect => 'two 1 2' },
+);
+
+while ( @tests ) {
+
+ my $name = shift @tests;
+ my $data = shift @tests;
+
+ # Run tests for path with trailing slash and without
+ SKIP: for my $req_uri
+ (
+ join( '' => $uri_base, $data->{ path } ), # Without trailing path
+ join( '' => $uri_base, $data->{ path }, '/' ), # With trailing path
+ ) {
+ my $end_slash = ( $req_uri =~ qr(/$) ? 1 : 0 );
+
+ # use slash_expect argument if URI ends with slash
+ # and the slash_expect argument is defined
+ my $expect = $data->{ expect } || '';
+ if ( $end_slash and exists $data->{ slash_expect } ) {
+ $expect = $data->{ slash_expect };
+ }
+
+ # Call the URI on the TestApp
+ my $response = request( $req_uri );
+
+ # Leave expect out to see the result
+ unless ( $expect ) {
+ skip 'Nothing expected, winner is ' . $response->content, 1;
+ }
+
+ # Show error if response was no success
+ if ( not $response->is_success ) {
+ diag 'Error: ' . $response->headers->{ 'x-catalyst-error' };
+ }
+
+ # Test if content matches expectations.
+ # TODO This might flood the screen with the catalyst please-come-later
+ # page. So I don't know it is a good idea.
+ is( $response->content, $expect,
+ "$name: @{[ $data->{ expect } ]} wins"
+ . ( $end_slash ? ' (trailing slash)' : '' )
+ );
+ }
+}
@@ -0,0 +1,33 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 3;
+use Catalyst::Test 'TestApp';
+
+local $^W = 0;
+
+SKIP:
+{
+ # Net::HTTP::Methods crashes when talking to a remote server because this
+ # test causes a very long header line to be sent
+ if ( $ENV{CATALYST_SERVER} ) {
+ skip 'Using remote server', 3;
+ }
+
+ ok( my $response = request('http://localhost/recursion_test'), 'Request' );
+ ok( !$response->is_success, 'Response Not Successful' );
+ is( $response->header('X-Catalyst-Error'), 'Deep recursion detected calling "/recursion_test"', 'Deep Recursion Detected' );
+}
@@ -0,0 +1,17 @@
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+use strict;
+use warnings;
+
+use File::Spec;
+use FindBin ();
+use Test::More;
+use Test::NoTabs;
+
+all_perl_files_ok(qw/lib/);
@@ -0,0 +1,15 @@
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+use strict;
+use warnings;
+use Test::More;
+
+use Test::Pod 1.14;
+
+all_pod_files_ok();
@@ -0,0 +1,23 @@
+
+BEGIN {
+ unless ($ENV{AUTHOR_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for testing by the author');
+ }
+}
+
+use strict;
+use warnings;
+use Test::More;
+
+use Pod::Coverage 0.19;
+use Test::Pod::Coverage 1.04;
+
+my @modules = all_modules;
+our @private = ( 'BUILD' );
+foreach my $module (@modules) {
+ local @private = (@private, 'run') if $module =~ /^Catalyst::Script::/;
+ pod_coverage_ok($module, { also_private => \@private });
+}
+
+done_testing;
@@ -0,0 +1,18 @@
+package ACLTestApp::Controller::Root;
+use Test::More;
+
+use base 'Catalyst::Controller';
+
+__PACKAGE__->config->{namespace} = '';
+
+sub foobar : Private {
+ die $Catalyst::DETACH;
+}
+
+sub gorch : Local {
+ my ( $self, $c, $frozjob ) = @_;
+ is $frozjob, 'wozzle';
+ $c->res->body("gorch");
+}
+
+1;
@@ -0,0 +1,26 @@
+package ACLTestApp;
+use Test::More;
+
+use strict;
+use warnings;
+use MRO::Compat;
+use Scalar::Util ();
+
+use base qw/Catalyst Catalyst::Controller/;
+use Catalyst qw//;
+
+sub execute {
+ my $c = shift;
+ my ( $class, $action ) = @_;
+
+ if ( Scalar::Util::blessed($action)
+ and $action->name ne "foobar" ) {
+ eval { $c->detach( 'foobar', [$action, 'foo'] ) };
+ }
+
+ $c->next::method( @_ );
+}
+
+__PACKAGE__->setup;
+
+1;
@@ -0,0 +1,42 @@
+package CDICompatTestPlugin;
+
+# This plugin specificially tests an edge case of C::D::I compat,
+# where you load a plugin which creates an accessor with the same
+# name as a class data accessor (_config in this case)..
+
+# This is what happens if you use the authentication back-compat
+# stuff, as C::A::Plugin::Credential::Password is added to the plugin
+# list, and that uses base C::A::C::P class, does the mk_accessors.
+
+# If a class data method called _config hasn't been created in
+# MyApp ($app below), then our call to ->config gets our accessor
+# (rather than the class data one), and we fail..
+
+use strict;
+use warnings;
+use base qw/Class::Accessor::Fast/;
+use MRO::Compat;
+__PACKAGE__->mk_accessors(qw/_config/);
+
+sub setup {
+ my $app = shift;
+
+ $app->config;
+ $app->next::method(@_);
+}
+
+# However, if we are too enthusiastic about adding accessors to the
+# MyApp package, then this method isn't called (as there is a local
+# symbol already).
+
+# Note - use a different package here, so that Moose's
+# package detection code doesn't get confused..
+$CDICompatTestPlugin::Data::HAS_RUN_SETUP_FINISHED = 0;
+
+sub setup_finished {
+ my $app = shift;
+ $CDICompatTestPlugin::Data::HAS_RUN_SETUP_FINISHED = 1;
+ $app->next::method(@_);
+}
+
+1;
@@ -8,7 +8,7 @@ use base qw/Catalyst::Action/;
sub execute {
my $self = shift;
my ( $controller, $c ) = @_;
- $self->NEXT::execute( @_ );
+ $self->next::method( @_ );
$c->res->header( 'X-Action-After', $c->stash->{after_message} );
}
@@ -9,7 +9,7 @@ sub execute {
my $self = shift;
my ( $controller, $c ) = @_;
$c->stash->{test} = 'works';
- $self->NEXT::execute( @_ );
+ $self->next::method( @_ );
}
1;
@@ -0,0 +1,17 @@
+package Catalyst::Plugin::Test::Deprecated;
+
+use strict;
+use warnings;
+
+sub prepare {
+ my $class = shift;
+ # Note: This use of NEXT is deliberately left here (without a use NEXT)
+ # to ensure back compat, as NEXT always used to be loaded, but
+ # is now replaced by Class::C3::Adopt::NEXT.
+ my $c = $class->NEXT::prepare(@_);
+ $c->response->header( 'X-Catalyst-Plugin-Deprecated' => 1 );
+
+ return $c;
+}
+
+1;
@@ -1,12 +1,13 @@
package Catalyst::Plugin::Test::Errors;
use strict;
+use MRO::Compat;
sub error {
my $c = shift;
unless ( $_[0] ) {
- return $c->NEXT::error(@_);
+ return $c->next::method(@_);
}
if ( $_[0] =~ /^(Unknown resource|No default action defined)/ ) {
@@ -26,7 +27,7 @@ sub error {
$c->response->headers->push_header( 'X-Catalyst-Error' => $error );
- $c->NEXT::error(@_);
+ $c->next::method(@_);
}
1;
@@ -1,11 +1,12 @@
package Catalyst::Plugin::Test::Headers;
use strict;
+use MRO::Compat;
sub prepare {
my $class = shift;
- my $c = $class->NEXT::prepare(@_);
+ my $c = $class->next::method(@_);
$c->response->header( 'X-Catalyst-Engine' => $c->engine );
$c->response->header( 'X-Catalyst-Debug' => $c->debug ? 1 : 0 );
@@ -26,7 +27,7 @@ sub prepare {
sub prepare_action {
my $c = shift;
- $c->NEXT::prepare_action(@_);
+ $c->next::method(@_);
$c->res->header( 'X-Catalyst-Action' => $c->req->action );
}
@@ -0,0 +1,16 @@
+package Catalyst::Plugin::Test::MangleDollarUnderScore;
+use strict;
+use warnings;
+
+our $VERSION = 0.1; # Make is_class_loaded happy
+
+# Class::MOP::load_class($_) can hurt you real hard.
+BEGIN { $_ = q{
+mst sayeth, Class::MOP::load_class($_) will ruin your life
+rafl spokeh "i ♥ my $_"',
+and verrily forsooth, t0m made tests
+and yea, there was fail' }; }
+
+1;
+__END__
+
@@ -1,8 +1,10 @@
package Catalyst::Plugin::Test::Plugin;
use strict;
+use warnings;
+use MRO::Compat;
-use base qw/Catalyst::Base Class::Data::Inheritable/;
+use base qw/Class::Data::Inheritable/;
__PACKAGE__->mk_classdata('ran_setup');
@@ -11,19 +13,23 @@ sub setup {
$c->ran_setup('1');
}
-sub prepare {
-
+sub prepare {
my $class = shift;
- my $c = $class->NEXT::prepare(@_);
+ my $c = $class->next::method(@_);
$c->response->header( 'X-Catalyst-Plugin-Setup' => $c->ran_setup );
return $c;
-
}
-sub end : Private {
- my ($self,$c) = @_;
+# Note: Catalyst::Plugin::Server forces the body to
+# be parsed, by calling the $c->req->body method in prepare_action.
+# We need to test this, as this was broken by 5.80. See also
+# t/aggregate/live_engine_request_body.t.
+sub prepare_action {
+ my $c = shift;
+ $c->res->header('X-Have-Request-Body', 1) if $c->req->body;
+ $c->next::method(@_);
}
1;
@@ -0,0 +1,9 @@
+package Catalyst::Script::Bar;
+use Moose;
+use namespace::autoclean;
+
+with 'Catalyst::ScriptRole';
+
+sub run { __PACKAGE__ }
+
+1;
@@ -0,0 +1,16 @@
+package Catalyst::Script::Baz;
+use Moose;
+use namespace::autoclean;
+
+use Test::More;
+
+with 'Catalyst::ScriptRole';
+
+sub run { __PACKAGE__ }
+
+after new_with_options => sub {
+ my ($self, %args) = @_;
+ is_deeply \%args, { application_name => 'ScriptTestApp' }, 'App name correct';
+};
+
+1;
@@ -0,0 +1,16 @@
+package Catalyst::Script::CompileTest;
+use Moose;
+use namespace::autoclean;
+
+use Test::More;
+
+with 'Catalyst::ScriptRole';
+
+sub run { __PACKAGE__ }
+
+after new_with_options => sub {
+ my ($self, %args) = @_;
+ is_deeply \%args, { application_name => 'ScriptTestApp' }, 'App name correct';
+};
+
+1;
@@ -0,0 +1,63 @@
+package ChainedActionsApp::Controller::Root;
+use Moose;
+use namespace::autoclean;
+
+BEGIN { extends 'Catalyst::Controller' }
+
+#
+# Sets the actions in this controller to be registered with no prefix
+# so they function identically to actions created in MyApp.pm
+#
+__PACKAGE__->config(namespace => '');
+
+sub setup : Chained('/') PathPart('') CaptureArgs(0) {
+ my ( $self, $c ) = @_;
+ # Common things here are to check for ACL and setup global contexts
+}
+
+sub home : Chained('setup') PathPart('') Args(0) {
+ my($self,$c) = @_;
+ $c->response->body( "Application Home Page" );
+}
+
+sub home_base : Chained('setup') PathPart('') CaptureArgs(2) {
+ my($self,$c,$proj_id,$title) = @_;
+ $c->stash({project_id=>$proj_id, project_title=>$title});
+}
+
+sub hpages : Chained('home_base') PathPart('') Args(0) {
+ my($self,$c) = @_;
+ $c->response->body( "List project " . $c->stash->{project_title} . " pages");
+}
+
+sub hpage : Chained('home_base') PathPart('') Args(2) {
+ my($self,$c,$page_id, $pagetitle) = @_;
+ $c->response->body( "This is $pagetitle page of " . $c->stash->{project_title} . " project" );
+}
+
+sub no_account : Chained('setup') PathPart('account') Args(0) {
+ my($self,$c) = @_;
+ $c->response->body( "New account o login" );
+}
+
+sub account_base : Chained('setup') PathPart('account') CaptureArgs(1) {
+ my($self,$c,$acc_id) = @_;
+ $c->stash({account_id=>$acc_id});
+}
+
+sub account : Chained('account_base') PathPart('') Args(0) {
+ my($self,$c,$acc) = @_;
+ $c->response->body( "This is account " . $c->stash->{account_id} );
+}
+
+sub default : Chained('setup') PathPart('') Args() {
+ my ( $self, $c ) = @_;
+ $c->response->body( 'Page not found' );
+ $c->response->status(404);
+}
+
+sub end : Action {}
+
+__PACKAGE__->meta->make_immutable;
+
+1;
@@ -0,0 +1,21 @@
+package ChainedActionsApp;
+use Moose;
+use namespace::autoclean;
+
+use Catalyst::Runtime 5.80;
+
+use Catalyst qw//;
+
+extends 'Catalyst';
+
+our $VERSION = "0.01";
+$VERSION = eval $VERSION;
+
+__PACKAGE__->config(
+ name => 'ChainedActionsApp',
+ disable_component_regex_fallback => 1,
+);
+
+__PACKAGE__->setup;
+
+1;
@@ -0,0 +1,30 @@
+package DeprecatedActionsInAppClassTestApp;
+
+use strict;
+use warnings;
+use Catalyst;
+
+our $VERSION = '0.01';
+
+__PACKAGE__->config( name => 'DeprecatedActionsInAppClassTestApp', root => '/some/dir' );
+__PACKAGE__->log(DeprecatedActionsInAppClassTestApp::Log->new);
+__PACKAGE__->setup;
+
+sub foo : Local {
+ my ($self, $c) = @_;
+ $c->res->body('OK');
+}
+
+package DeprecatedActionsInAppClassTestApp::Log;
+use strict;
+use warnings;
+use base qw/Catalyst::Log/;
+
+our $warnings;
+
+sub warn {
+ my ($self, $warning) = @_;
+ $warnings++ if $warning =~ /action methods .+ found defined/i;
+}
+
+1;
@@ -0,0 +1,18 @@
+package DeprecatedTestApp::C::Root;
+use strict;
+use warnings;
+use base qw/Catalyst::Controller/;
+
+__PACKAGE__->config->{namespace} = '';
+
+sub index : Private {
+ my ( $self, $c ) = @_;
+ $c->res->body('root index');
+}
+
+sub req_user : Local {
+ my ( $self, $c ) = @_;
+ $c->res->body('REMOTE_USER = ' . $c->req->user);
+}
+
+1;
@@ -0,0 +1,14 @@
+package DeprecatedTestApp;
+
+use strict;
+use Catalyst qw/
+ Test::Deprecated
+/;
+
+our $VERSION = '0.01';
+
+__PACKAGE__->config( name => 'DeprecatedTestApp', root => '/some/dir' );
+
+__PACKAGE__->setup;
+
+1;
@@ -0,0 +1,7 @@
+package NullPackage;
+# Do nothing class, there should be no code or symbols defined here..
+# Loading this works fine in 5.70, but a die was introduced in 5.80 which caused
+# it to fail. This has been changed to a warning to maintain back-compat.
+# See Catalyst::Utils::ensure_class_loaded() for more info.
+1;
+
@@ -0,0 +1,62 @@
+package PluginTestApp::Controller::Root;
+use Test::More;
+
+use base 'Catalyst::Controller';
+
+#use Catalyst qw(
+# Test::Plugin
+# +TestApp::Plugin::FullyQualified
+# );
+
+__PACKAGE__->config->{namespace} = '';
+
+sub compile_time_plugins : Local {
+ my ( $self, $c ) = @_;
+
+ isa_ok $c, 'Catalyst::Plugin::Test::Plugin';
+ isa_ok $c, 'TestApp::Plugin::FullyQualified';
+
+ can_ok $c, 'registered_plugins';
+ $c->_test_plugins;
+
+ $c->res->body("ok");
+}
+
+sub run_time_plugins : Local {
+ my ( $self, $c ) = @_;
+
+ $c->_test_plugins;
+ my $faux_plugin = 'Faux::Plugin';
+
+# Trick perl into thinking the plugin is already loaded
+ $INC{'Faux/Plugin.pm'} = 1;
+
+ ref($c)->plugin( faux => $faux_plugin );
+
+ isa_ok $c, 'Catalyst::Plugin::Test::Plugin';
+
+ # applied parameterized role
+ if (eval { require MooseX::Role::Parameterized; 1 }) {
+ can_ok $c, 'affe';
+ is $c->affe, 'birne', 'right method created by parameterized role';
+ }
+
+ isa_ok $c, 'TestApp::Plugin::FullyQualified';
+ ok !$c->isa($faux_plugin),
+ '... and it should not inherit from the instant plugin';
+ can_ok $c, 'faux';
+ is $c->faux->count, 1, '... and it should behave correctly';
+ is_deeply [ $c->registered_plugins ],
+ [
+ qw/Catalyst::Plugin::Test::Plugin
+ Faux::Plugin
+ TestApp::Plugin::FullyQualified/
+ ],
+ 'registered_plugins() should report all plugins';
+ ok $c->registered_plugins('Faux::Plugin'),
+ '... and even the specific instant plugin';
+
+ $c->res->body("ok");
+}
+
+1;
@@ -1,52 +1,13 @@
package PluginTestApp;
use Test::More;
-use Catalyst qw(
- Test::Plugin
- +TestApp::Plugin::FullyQualified
- );
-
-sub compile_time_plugins : Local {
- my ( $self, $c ) = @_;
-
- isa_ok $c, 'Catalyst::Plugin::Test::Plugin';
- isa_ok $c, 'TestApp::Plugin::FullyQualified';
-
- can_ok $c, 'registered_plugins';
- $c->_test_plugins;
-
- $c->res->body("ok");
-}
-
-sub run_time_plugins : Local {
- my ( $self, $c ) = @_;
-
- $c->_test_plugins;
- my $faux_plugin = 'Faux::Plugin';
-
-# Trick perl into thinking the plugin is already loaded
- $INC{'Faux/Plugin.pm'} = 1;
-
- __PACKAGE__->plugin( faux => $faux_plugin );
-
- isa_ok $c, 'Catalyst::Plugin::Test::Plugin';
- isa_ok $c, 'TestApp::Plugin::FullyQualified';
- ok !$c->isa($faux_plugin),
- '... and it should not inherit from the instant plugin';
- can_ok $c, 'faux';
- is $c->faux->count, 1, '... and it should behave correctly';
- is_deeply [ $c->registered_plugins ],
- [
- qw/Catalyst::Plugin::Test::Plugin
- Faux::Plugin
- TestApp::Plugin::FullyQualified/
- ],
- 'registered_plugins() should report all plugins';
- ok $c->registered_plugins('Faux::Plugin'),
- '... and even the specific instant plugin';
-
- $c->res->body("ok");
-}
+use Catalyst (
+ 'Test::Plugin',
+ '+TestApp::Plugin::FullyQualified',
+ (eval { require MooseX::Role::Parameterized; 1 }
+ ? ('+TestApp::Plugin::ParameterizedRole' => { method_name => 'affe' })
+ : ()),
+);
sub _test_plugins {
my $c = shift;
@@ -0,0 +1,9 @@
+package ScriptTestApp::Script::Bar;
+use Moose;
+use namespace::autoclean;
+
+with 'Catalyst::ScriptRole';
+
+sub run { __PACKAGE__ }
+
+1;
@@ -0,0 +1,7 @@
+package ScriptTestApp::Script::CompileTest;
+use Moose;
+use namespace::autoclean;
+
+die("Does not compile");
+
+1;
@@ -0,0 +1,9 @@
+package ScriptTestApp::Script::Foo;
+use Moose;
+use namespace::autoclean;
+
+with 'Catalyst::ScriptRole';
+
+sub run { __PACKAGE__ }
+
+1;
@@ -9,7 +9,7 @@ sub execute {
my $self = shift;
my ( $controller, $c, $test ) = @_;
$c->res->header( 'X-TestAppActionTestBefore', $test );
- $self->NEXT::execute( @_ );
+ $self->next::method( @_ );
}
1;
@@ -0,0 +1,17 @@
+package TestApp::Action::TestExtraArgsAction;
+
+use Moose;
+use namespace::autoclean;
+
+extends 'Catalyst::Action';
+
+has [qw/extra_arg another_extra_arg/] => (is => 'ro');
+
+after execute => sub {
+ my ($self, $controller, $ctx) = @_;
+ $ctx->response->header('X-TestExtraArgsAction' => join q{,} => $self->extra_arg, $self->another_extra_arg);
+};
+
+__PACKAGE__->meta->make_immutable;
+
+1;
@@ -9,7 +9,10 @@ sub execute {
my $self = shift;
my ( $controller, $c, $test ) = @_;
$c->res->header( 'X-TestAppActionTestMyAction', 'MyAction works' );
- $self->NEXT::execute(@_);
+ $c->res->header( 'X-Component-Name-Action', $controller->catalyst_component_name);
+ $c->res->header( 'X-Component-Instance-Name-Action', ref($controller));
+ $c->res->header( 'X-Class-In-Action', $self->class);
+ $self->next::method(@_);
}
1;
@@ -3,6 +3,16 @@ package TestApp::Controller::Action::Action;
use strict;
use base 'TestApp::Controller::Action';
+__PACKAGE__->config(
+ actions => {
+ action_action_five => { ActionClass => '+Catalyst::Action::TestBefore' },
+ },
+ action_args => {
+ '*' => { extra_arg => 42 },
+ action_action_seven => { another_extra_arg => 23 },
+ },
+);
+
sub action_action_one : Global : ActionClass('TestBefore') {
my ( $self, $c ) = @_;
$c->res->header( 'X-Action', $c->stash->{test} );
@@ -25,4 +35,20 @@ sub action_action_four : Global : MyAction('TestMyAction') {
$c->forward('TestApp::View::Dump::Request');
}
+sub action_action_five : Global {
+ my ( $self, $c ) = @_;
+ $c->res->header( 'X-Action', $c->stash->{test} );
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+sub action_action_six : Global : ActionClass('~TestMyAction') {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+sub action_action_seven : Global : ActionClass('~TestExtraArgsAction') {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Request');
+}
+
1;
@@ -0,0 +1,35 @@
+package TestApp::Controller::Action::Chained::ArgsOrder;
+use warnings;
+use strict;
+
+use base qw( Catalyst::Controller );
+
+#
+# This controller builds a simple chain of three actions that
+# will output the arguments they got passed to @_ after the
+# context object. We do this to test if that passing works
+# as it should.
+#
+
+sub base :Chained('/') PathPart('argsorder') CaptureArgs(0) {
+ my ( $self, $c, $arg ) = @_;
+ push @{ $c->stash->{ passed_args } }, 'base', $arg;
+}
+
+sub index :Chained('base') PathPart('') Args(0) {
+ my ( $self, $c, $arg ) = @_;
+ push @{ $c->stash->{ passed_args } }, 'index', $arg;
+}
+
+sub all :Chained('base') PathPart('') Args() {
+ my ( $self, $c, $arg ) = @_;
+ push @{ $c->stash->{ passed_args } }, 'all', $arg;
+}
+
+sub end : Private {
+ my ( $self, $c ) = @_;
+ no warnings 'uninitialized';
+ $c->response->body( join '; ', @{ $c->stash->{ passed_args } } );
+}
+
+1;
@@ -0,0 +1,66 @@
+package TestApp::Controller::Action::Chained::CaptureArgs;
+use warnings;
+use strict;
+
+use base qw( Catalyst::Controller );
+
+#
+# This controller build the following patterns of URI:
+# /captureargs/*/*
+# /captureargs/*/*/edit
+# /captureargs/*
+# /captureargs/*/edit
+# /captureargs/test/*
+# It will output the arguments they got passed to @_ after the
+# context object.
+# /captureargs/one/edit should not dispatch to /captureargs/*/*
+# /captureargs/test/one should not dispatch to /captureargs/*/*
+
+sub base :Chained('/') PathPart('captureargs') CaptureArgs(0) {
+ my ( $self, $c, $arg ) = @_;
+ push @{ $c->stash->{ passed_args } }, 'base';
+}
+
+sub two_args :Chained('base') PathPart('') CaptureArgs(2) {
+ my ( $self, $c, $arg1, $arg2 ) = @_;
+ push @{ $c->stash->{ passed_args } }, 'two_args', $arg1, $arg2;
+}
+
+sub one_arg :Chained('base') ParthPart('') CaptureArgs(1) {
+ my ( $self, $c, $arg ) = @_;
+ push @{ $c->stash->{ passed_args } }, 'one_arg', $arg;
+}
+
+sub edit_two_args :Chained('two_args') PathPart('edit') Args(0) {
+ my ( $self, $c ) = @_;
+ push @{ $c->stash->{ passed_args } }, 'edit_two_args';
+}
+
+sub edit_one_arg :Chained('one_arg') PathPart('edit') Args(0) {
+ my ( $self, $c ) = @_;
+ push @{ $c->stash->{ passed_args } }, 'edit_one_arg';
+}
+
+sub view_two_args :Chained('two_args') PathPart('') Args(0) {
+ my ( $self, $c ) = @_;
+ push @{ $c->stash->{ passed_args } }, 'view_two_args';
+}
+
+sub view_one_arg :Chained('one_arg') PathPart('') Args(0) {
+ my ( $self, $c ) = @_;
+ push @{ $c->stash->{ passed_args } }, 'view_one_arg';
+}
+
+sub test_plus_arg :Chained('base') PathPart('test') Args(1) {
+ my ( $self, $c, $arg ) = @_;
+ push @{ $c->stash->{ passed_args } }, 'test_plus_arg', $arg;
+}
+
+
+sub end : Private {
+ my ( $self, $c ) = @_;
+ no warnings 'uninitialized';
+ $c->response->body( join '; ', @{ $c->stash->{ passed_args } } );
+}
+
+1;
@@ -30,8 +30,7 @@ sub cross2 :PathPart('end') :Chained('/action/chained/bar/cross1') :Args(1) { }
#
sub to_root : Chained('/') PathPart('action/chained/to_root') {
my ( $self, $c ) = @_;
- my $uri = $c->uri_for(
- $c->controller('Root')->action_for('chain_root_index') );
+ my $uri = $c->uri_for_action('/chain_root_index');
$c->res->body( "URI:$uri" );
$c->stash->{no_end}++;
}
@@ -0,0 +1,10 @@
+package TestApp::Controller::Action::Chained::ParentChain::Relative;
+use warnings;
+use strict;
+
+use base qw/ Catalyst::Controller /;
+
+# using ../ to go up more than one level
+sub chained_rel_two : Chained('../../one') Args(2) { }
+
+1;
@@ -10,4 +10,16 @@ use base qw/ Catalyst::Controller /;
#
sub child :Chained('.') :Args(1) { }
+# Should be at /chained/rootdef/*/chained_rel/*/*
+sub chained_rel :Chained('../one') Args(2) {
+}
+
+# Should chain to loose in parent namespace - i.e. at /chained/loose/*/loose/*/*
+sub loose : ChainedParent Args(2) {
+}
+
+# Should be at /chained/cross/*/up_down/*
+sub up_down : Chained('../bar/cross1') Args(1) {
+}
+
1;
@@ -0,0 +1,12 @@
+package TestApp::Controller::Action::Chained::PathPrefix;
+
+use strict;
+use warnings;
+
+use base qw/Catalyst::Controller/;
+
+# this is kinda the same thing as: sub instance : Path {}
+# it should respond to: /action/chained/pathprefix/*
+sub instance : Chained('/') PathPrefix Args(1) { }
+
+1;
@@ -3,6 +3,8 @@ package TestApp::Controller::Action::Chained;
use strict;
use warnings;
+use HTML::Entities;
+
use base qw/Catalyst::Controller/;
sub begin :Private { }
@@ -15,7 +17,11 @@ sub begin :Private { }
#
# Simple parent/child action test
#
-sub foo :PathPart('chained/foo') :CaptureArgs(1) :Chained('/') { }
+sub foo :PathPart('chained/foo') :CaptureArgs(1) :Chained('/') {
+ my ( $self, $c, @args ) = @_;
+ die "missing argument" unless @args;
+ die "more than 1 argument" if @args > 1;
+}
sub endpoint :PathPart('end') :Chained('/action/chained/foo') :Args(1) { }
#
@@ -159,21 +165,52 @@ sub mult_nopp_idall : Chained('mult_nopp_id') PathPart('') Args(0) { }
sub mult_nopp_idnew : Chained('mult_nopp_id') PathPart('new') Args(0) { }
#
-# Test Choice between branches and early return logic
+# Test Choice between branches and early return logic
# Declaration order is important for $children->{$*}, since this is first match best.
#
-sub cc_base : Chained('/') PathPart('chained/choose_capture') CaptureArgs(0) { }
-sub cc_link : Chained('cc_base') PathPart('') CaptureArgs(0) { }
-sub cc_anchor : Chained('cc_link') PathPart('anchor.html') Args(0) { }
-sub cc_all : Chained('cc_base') PathPart('') Args() { }
+sub cc_base : Chained('/') PathPart('chained/choose_capture') CaptureArgs(0) { }
+sub cc_link : Chained('cc_base') PathPart('') CaptureArgs(0) { }
+sub cc_anchor : Chained('cc_link') PathPart('anchor.html') Args(0) { }
+sub cc_all : Chained('cc_base') PathPart('') Args() { }
+
+sub cc_a : Chained('cc_base') PathPart('') CaptureArgs(1) { }
+sub cc_a_link : Chained('cc_a') PathPart('a') CaptureArgs(0) { }
+sub cc_a_anchor : Chained('cc_a_link') PathPart('') Args() { }
+
+sub cc_b : Chained('cc_base') PathPart('b') CaptureArgs(0) { }
+sub cc_b_link : Chained('cc_b') PathPart('') CaptureArgs(1) { }
+sub cc_b_anchor : Chained('cc_b_link') PathPart('anchor.html') Args() { }
+
+#
+# Test static paths vs. captures
+#
-sub cc_a : Chained('cc_base') PathPart('') CaptureArgs(1) { }
-sub cc_a_link : Chained('cc_a') PathPart('a') CaptureArgs(0) { }
-sub cc_a_anchor : Chained('cc_a_link') PathPart('') Args() { }
+sub apan : Chained('/') CaptureArgs(0) PathPrefix { }
+sub korv : Chained('apan') CaptureArgs(0) PathPart('') { }
+sub wurst : Chained('apan') CaptureArgs(1) PathPart('') { }
+sub static_end : Chained('korv') Args(0) { }
+sub capture_end : Chained('wurst') Args(0) PathPart('') { }
-sub cc_b : Chained('cc_base') PathPart('b') CaptureArgs(0) { }
-sub cc_b_link : Chained('cc_b') PathPart('') CaptureArgs(1) { }
-sub cc_b_anchor : Chained('cc_b_link') PathPart('anchor.html') Args() { }
+
+# */search vs doc/*
+sub view : Chained('/') PathPart('chained') CaptureArgs(1) {}
+sub star_search : Chained('view') PathPart('search') Args(0) { }
+sub doc_star : Chained('/') PathPart('chained/doc') Args(1) {}
+
+sub return_arg : Chained('view') PathPart('return_arg') Args(1) {}
+
+sub return_arg_decoded : Chained('/') PathPart('chained/return_arg_decoded') Args(1) {
+ my ($self, $c) = @_;
+ $c->req->args([ map { decode_entities($_) } @{ $c->req->args }]);
+}
+
+sub roundtrip_urifor : Chained('/') PathPart('chained/roundtrip_urifor') CaptureArgs(1) {}
+sub roundtrip_urifor_end : Chained('roundtrip_urifor') PathPart('') Args(1) {
+ my ($self, $c) = @_;
+ # This should round-trip, always - i.e. the uri you put in should come back out.
+ $c->res->body($c->uri_for($c->action, $c->req->captures, @{$c->req->args}, $c->req->parameters));
+ $c->stash->{no_end} = 1;
+}
sub end :Private {
my ($self, $c) = @_;
@@ -57,6 +57,11 @@ sub with_method_and_args : Local {
$c->res->body( $c->req->args->[0] );
}
+sub to_action_object : Local {
+ my ( $self, $c ) = @_;
+ $c->forward($self->action_for('embed'), [qw/mtfnpy/]);
+}
+
sub args : Local {
my ( $self, $c, $val ) = @_;
die "Expected argument 'new', got '$val'" unless $val eq 'new';
@@ -85,4 +90,9 @@ sub class_forward_test_action : Local {
$c->forward(qw/TestApp class_forward_test_method/);
}
+sub forward_to_uri_check : Local {
+ my ( $self, $c ) = @_;
+ $c->forward( 'Action::ForwardTo', 'uri_check' );
+}
+
1;
@@ -0,0 +1,11 @@
+package TestApp::Controller::Action::ForwardTo;
+
+use strict;
+use base 'TestApp::Controller::Action';
+
+sub uri_check : Private {
+ my ( $self, $c ) = @_;
+ $c->res->body( $c->uri_for('foo/bar')->path );
+}
+
+1;
@@ -0,0 +1,102 @@
+package TestApp::Controller::Action::Go;
+
+use strict;
+use base 'TestApp::Controller::Action';
+
+sub one : Local {
+ my ( $self, $c ) = @_;
+ $c->go('two');
+}
+
+sub two : Private {
+ my ( $self, $c ) = @_;
+ $c->go('three');
+}
+
+sub three : Local {
+ my ( $self, $c ) = @_;
+ $c->go( $self, 'four' );
+}
+
+sub four : Private {
+ my ( $self, $c ) = @_;
+ $c->go('/action/go/five');
+}
+
+sub five : Local {
+ my ( $self, $c ) = @_;
+ $c->forward('View::Dump::Request');
+}
+
+sub inheritance : Local {
+ my ( $self, $c ) = @_;
+ $c->go('/action/inheritance/a/b/default');
+}
+
+sub global : Local {
+ my ( $self, $c ) = @_;
+ $c->go('/global_action');
+}
+
+sub with_args : Local {
+ my ( $self, $c, $arg ) = @_;
+ $c->go( 'args', [$arg] );
+}
+
+sub with_method_and_args : Local {
+ my ( $self, $c, $arg ) = @_;
+ $c->go( qw/TestApp::Controller::Action::Go args/, [$arg] );
+}
+
+sub args : Local {
+ my ( $self, $c, $val ) = @_;
+ die "passed argument does not match args" unless $val eq $c->req->args->[0];
+ $c->res->body($val);
+}
+
+sub go_die : Local {
+ my ( $self, $c, $val ) = @_;
+ eval { $c->go( 'args', [qq/new/] ) };
+ $c->res->body( $@ ? $@ : "go() did not die" );
+ die $Catalyst::GO;
+}
+
+sub go_chained : Local {
+ my ( $self, $c, $val ) = @_;
+ $c->go('/action/chained/foo/spoon', ['captureme'], [qw/arg1 arg2/]);
+}
+
+sub view : Local {
+ my ( $self, $c, $val ) = @_;
+ eval { $c->go('View::Dump') };
+ $c->res->body( $@ ? $@ : "go() did not die" );
+}
+
+sub model : Local {
+ my ( $self, $c, $val ) = @_;
+ eval { $c->go('Model::Foo') };
+ $c->res->body( $@ ? $@ : "go() did not die" );
+}
+
+sub args_embed_relative : Local {
+ my ( $self, $c ) = @_;
+ $c->go('embed/ok');
+}
+
+sub args_embed_absolute : Local {
+ my ( $self, $c ) = @_;
+ $c->go('/action/go/embed/ok');
+}
+
+sub embed : Local {
+ my ( $self, $c, $ok ) = @_;
+ $ok ||= 'not ok';
+ $c->res->body($ok);
+}
+
+sub class_go_test_action : Local {
+ my ( $self, $c ) = @_;
+ $c->go(qw/TestApp/);
+}
+
+1;
@@ -70,5 +70,17 @@ sub end : Private {
my ( $self, $c ) = @_;
}
+package TestApp::Controller::Action::Inheritance::B;
+
+use strict;
+use base 'TestApp::Controller::Action';
+
+# check configuration for an inherited action
+__PACKAGE__->config(
+ action => {
+ begin => {}
+ }
+);
+
1;
@@ -23,4 +23,9 @@ sub four : Action Path('four/five/six') {
$c->forward('TestApp::View::Dump::Request');
}
+sub five : Action Local Args(1) {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Request');
+}
+
1;
@@ -7,6 +7,7 @@ __PACKAGE__->config(
actions => {
'one' => { 'Path' => [ 'a path with spaces' ] },
'two' => { 'Path' => "åäö" },
+ 'six' => { 'Local' => undef },
},
);
@@ -35,4 +36,9 @@ sub five : Path( "spaces_near_parens_doubleq" ) {
$c->forward('TestApp::View::Dump::Request');
}
+sub six {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Request');
+}
+
1;
@@ -8,27 +8,27 @@ sub default : Private {
$c->res->output('access denied');
}
-sub one : Private {
+sub one : Private {
my ( $self, $c ) = @_;
$c->res->output('access allowed');
}
-sub two : Private Relative {
+sub two : Private {
my ( $self, $c ) = @_;
$c->res->output('access allowed');
}
-sub three : Private Absolute {
+sub three : Private {
my ( $self, $c ) = @_;
$c->res->output('access allowed');
}
-sub four : Private Path('/action/private/four') {
+sub four : Private {
my ( $self, $c ) = @_;
$c->res->output('access allowed');
}
-sub five : Private Path('five') {
+sub five : Private {
my ( $self, $c ) = @_;
$c->res->output('access allowed');
}
@@ -18,4 +18,18 @@ sub three : Action LocalRegex('^(mandatory)(/optional)?$'){
$c->forward('TestApp::View::Dump::Request');
}
+sub four : Action Regex('^action/regexp/redirect/(\w+)/universe/(\d+)/everything$') {
+ my ( $self, $c ) = @_;
+ $c->res->redirect(
+ $c->uri_for($c->action, $c->req->captures,
+ @{$c->req->arguments}, $c->req->params
+ )
+ );
+}
+
+sub one_backslashes : Action Regex('^action/regexp/(\w+)/(\d+)\.html$') {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Request');
+}
+
1;
@@ -16,8 +16,8 @@ EOF
sub body : Local {
my ( $self, $c ) = @_;
-
- my $file = "$FindBin::Bin/01use.t";
+
+ my $file = "$FindBin::Bin/lib/TestApp/Controller/Action/Streaming.pm";
my $fh = IO::File->new( $file, 'r' );
if ( defined $fh ) {
$c->res->body( $fh );
@@ -27,4 +27,16 @@ sub body : Local {
}
}
+sub body_large : Local {
+ my ($self, $c) = @_;
+
+ # more than one write with the default chunksize
+ my $size = 128 * 1024;
+
+ my $data = "\0" x $size;
+ open my $fh, '<', \$data;
+ $c->res->content_length($size);
+ $c->res->body($fh);
+}
+
1;
@@ -17,4 +17,24 @@ sub relative_two : Local {
$c->forward( 'TestApp::Controller::Action::Forward', 'one' );
}
+sub relative_go : Local {
+ my ( $self, $c ) = @_;
+ $c->go('/action/go/one');
+}
+
+sub relative_go_two : Local {
+ my ( $self, $c ) = @_;
+ $c->go( 'TestApp::Controller::Action::Go', 'one' );
+}
+
+sub relative_visit : Local {
+ my ( $self, $c ) = @_;
+ $c->visit('/action/visit/one');
+}
+
+sub relative_visit_two : Local {
+ my ( $self, $c ) = @_;
+ $c->visit( 'TestApp::Controller::Action::Visit', 'one' );
+}
+
1;
@@ -0,0 +1,104 @@
+package TestApp::Controller::Action::Visit;
+
+use strict;
+use base 'TestApp::Controller::Action';
+
+sub one : Local {
+ my ( $self, $c ) = @_;
+ $c->visit('two');
+}
+
+sub two : Private {
+ my ( $self, $c ) = @_;
+ $c->visit('three');
+}
+
+sub three : Local {
+ my ( $self, $c ) = @_;
+ $c->visit( $self, 'four' );
+}
+
+sub four : Private {
+ my ( $self, $c ) = @_;
+ $c->visit('/action/visit/five');
+}
+
+sub five : Local {
+ my ( $self, $c ) = @_;
+ $c->forward('View::Dump::Request');
+}
+
+sub inheritance : Local {
+ my ( $self, $c ) = @_;
+ $c->visit('/action/inheritance/a/b/default');
+}
+
+sub global : Local {
+ my ( $self, $c ) = @_;
+ $c->visit('/global_action');
+}
+
+sub with_args : Local {
+ my ( $self, $c, $arg ) = @_;
+ $c->visit( 'args', [$arg] );
+}
+
+sub with_method_and_args : Local {
+ my ( $self, $c, $arg ) = @_;
+ $c->visit( qw/TestApp::Controller::Action::Visit args/, [$arg] );
+}
+
+sub args : Local {
+ my ( $self, $c, $val ) = @_;
+ die "passed argument does not match args" unless $val eq $c->req->args->[0];
+ $c->res->body($val);
+}
+
+sub visit_die : Local {
+ my ( $self, $c, $val ) = @_;
+ eval { $c->visit( 'args', [qq/new/] ) };
+ $c->res->body( $@ ? $@ : "visit() doesn't die" );
+}
+
+sub visit_chained : Local {
+ my ( $self, $c, $val, $capture, @args ) = @_;
+ my @cap_and_args = ([$capture], [@args]);
+ $val eq 1 ? $c->visit( '/action/chained/foo/spoon', @cap_and_args)
+ : $val eq 2 ? $c->visit( qw/ Action::Chained::Foo spoon /, @cap_and_args)
+ : $c->visit( $c->controller('Action::Chained::Foo')->action_for('spoon'), @cap_and_args)
+}
+
+sub view : Local {
+ my ( $self, $c, $val ) = @_;
+ eval { $c->visit('View::Dump') };
+ $c->res->body( $@ ? $@ : "visit() did not die" );
+}
+
+sub model : Local {
+ my ( $self, $c, $val ) = @_;
+ eval { $c->visit('Model::Foo') };
+ $c->res->body( $@ ? $@ : "visit() did not die" );
+}
+
+sub args_embed_relative : Local {
+ my ( $self, $c ) = @_;
+ $c->visit('embed/ok');
+}
+
+sub args_embed_absolute : Local {
+ my ( $self, $c ) = @_;
+ $c->visit('/action/visit/embed/ok');
+}
+
+sub embed : Local {
+ my ( $self, $c, $ok ) = @_;
+ $ok ||= 'not ok';
+ $c->res->body($ok);
+}
+
+sub class_visit_test_action : Local {
+ my ( $self, $c ) = @_;
+ $c->visit(qw/TestApp/);
+}
+
+1;
@@ -0,0 +1,39 @@
+package Anon::Trait;
+use Moose::Role -traits => 'MethodAttributes'; # Needed for role composition to work correctly with anon classes.
+
+after test => sub {
+ my ($self, $c) = @_;
+ $c->res->header('X-Anon-Trait-Applied', 1);
+};
+
+no Moose::Role;
+
+package TestApp::Controller::Anon;
+use Moose;
+use Moose::Util qw/find_meta/;
+use namespace::clean -except => 'meta';
+BEGIN { extends 'Catalyst::Controller' };
+
+sub COMPONENT { # Don't do this yourself, use CatalystX::Component::Traits!
+ my ($class, $app, $args) = @_;
+
+ my $meta = $class->meta->create_anon_class(
+ superclasses => [ $class->meta->name ],
+ roles => ['Anon::Trait'],
+ cache => 1,
+ );
+ # Special move as the methodattributes trait has changed our metaclass..
+ $meta = find_meta($meta->name);
+
+ $class = $meta->name;
+ $class->new($app, $args);
+}
+
+sub test : Local ActionClass('+TestApp::Action::TestMyAction') {
+ my ($self, $c) = @_;
+ $c->res->header('X-Component-Name-Controller', $self->catalyst_component_name);
+ $c->res->body('It works');
+}
+
+__PACKAGE__->meta->make_immutable;
+
@@ -1,8 +1,7 @@
package TestApp::Controller::Args;
use strict;
-use base 'Catalyst::Base';
-use Data::Dumper;
+use base 'Catalyst::Controller';
sub args :Local {
my ( $self, $c ) = @_;
@@ -14,4 +13,4 @@ sub params :Local {
$c->res->body( join('',@_) );
}
-1;
\ No newline at end of file
+1;
@@ -0,0 +1,30 @@
+use strict;
+use warnings;
+
+package My::AttributesBaseClass;
+use base qw( Catalyst::Controller );
+
+sub fetch : Chained('/') PathPrefix CaptureArgs(1) {
+
+}
+
+sub view : PathPart Chained('fetch') Args(0) {
+
+}
+
+sub foo { # no attributes
+
+}
+
+package TestApp::Controller::Attributes;
+use base qw(My::AttributesBaseClass);
+
+sub view { # override attributes to "hide" url
+
+}
+
+sub foo : Local {
+
+}
+
+1;
@@ -0,0 +1,29 @@
+package TestApp::Controller::ContextClosure;
+
+use Moose;
+
+BEGIN {
+ extends 'Catalyst::Controller';
+ with 'Catalyst::Component::ContextClosure';
+}
+
+sub normal_closure : Local {
+ my ($self, $ctx) = @_;
+ $ctx->stash(closure => sub {
+ $ctx->response->body('from normal closure');
+ });
+ $ctx->response->body('stashed normal closure');
+}
+
+sub context_closure : Local {
+ my ($self, $ctx) = @_;
+ $ctx->stash(closure => $self->make_context_closure(sub {
+ my ($ctx) = @_;
+ $ctx->response->body('from context closure');
+ }, $ctx));
+ $ctx->response->body('stashed context closure');
+}
+
+__PACKAGE__->meta->make_immutable;
+
+1;
@@ -1,26 +1,22 @@
package TestApp::Controller::Dump;
use strict;
-use base 'Catalyst::Base';
+use base 'Catalyst::Controller';
-sub default : Action Private {
+sub default : Action {
my ( $self, $c ) = @_;
$c->forward('TestApp::View::Dump');
}
sub env : Action Relative {
my ( $self, $c ) = @_;
- $c->stash( env => \%ENV );
- $c->forward('TestApp::View::Dump');
-}
-
-sub parameters : Action Relative {
- my ( $self, $c ) = @_;
- $c->forward('TestApp::View::Dump::Parameters');
+ $c->forward('TestApp::View::Dump::Env');
}
sub request : Action Relative {
my ( $self, $c ) = @_;
+ $c->req->params(undef); # Should be a no-op, and be ignored.
+ # Back compat test for 5.7
$c->forward('TestApp::View::Dump::Request');
}
@@ -29,4 +25,9 @@ sub response : Action Relative {
$c->forward('TestApp::View::Dump::Response');
}
+sub body : Action Relative {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Body');
+}
+
1;
@@ -1,7 +1,7 @@
package TestApp::Controller::Engine::Request::URI;
use strict;
-use base 'Catalyst::Base';
+use base 'Catalyst::Controller';
sub default : Private {
my ( $self, $c ) = @_;
@@ -32,11 +32,13 @@ sub uri_with : Local {
my ( $self, $c ) = @_;
# change the current uri
- my $uri = $c->req->uri_with( { b => 1 } );
+ my $uri = $c->req->uri_with( { b => 1, c => undef } );
my %query = $uri->query_form;
$c->res->header( 'X-Catalyst-Param-a' => $query{ a } );
$c->res->header( 'X-Catalyst-Param-b' => $query{ b } );
+ $c->res->header( 'X-Catalyst-Param-c' => exists($query{ c }) ? $query{ c } : '--notexists--' );
+ $c->res->header( 'X-Catalyst-query' => $uri->query);
$c->forward('TestApp::View::Dump::Request');
}
@@ -77,4 +79,26 @@ sub uri_with_undef : Local {
$c->forward('TestApp::View::Dump::Request');
}
+sub uri_with_undef_only : Local {
+ my ( $self, $c ) = @_;
+
+ my $uri = $c->req->uri_with( { a => undef } );
+
+ $c->res->header( 'X-Catalyst-uri-with' => "$uri" );
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+sub uri_with_undef_ignore : Local {
+ my ( $self, $c ) = @_;
+
+ my $uri = $c->req->uri_with( { a => 1, b => undef } );
+
+ my %query = $uri->query_form;
+ $c->res->header( 'X-Catalyst-uri-with' => "$uri" );
+ $c->res->header( 'X-Catalyst-Param-a' => $query{ a } );
+ $c->res->header( 'X-Catalyst-Param-b' => $query{ b } );
+ $c->res->header( 'X-Catalyst-Param-c' => $query{ c } );
+ $c->forward('TestApp::View::Dump::Request');
+}
+
1;
@@ -1,7 +1,7 @@
package TestApp::Controller::Engine::Request::Uploads;
use strict;
-use base 'Catalyst::Base';
+use base 'Catalyst::Controller';
sub slurp : Relative {
my ( $self, $c ) = @_;
@@ -1,19 +1,19 @@
package TestApp::Controller::Engine::Response::Cookies;
use strict;
-use base 'Catalyst::Base';
+use base 'Catalyst::Controller';
sub one : Local {
my ( $self, $c ) = @_;
- $c->res->cookies->{Catalyst} = { value => 'Cool', path => '/bah' };
- $c->res->cookies->{Cool} = { value => 'Catalyst', path => '/' };
+ $c->res->cookies->{catalyst} = { value => 'cool', path => '/bah' };
+ $c->res->cookies->{cool} = { value => 'catalyst', path => '/' };
$c->forward('TestApp::View::Dump::Request');
}
sub two : Local {
my ( $self, $c ) = @_;
- $c->res->cookies->{Catalyst} = { value => 'Cool', path => '/bah' };
- $c->res->cookies->{Cool} = { value => 'Catalyst', path => '/' };
+ $c->res->cookies->{catalyst} = { value => 'cool', path => '/bah' };
+ $c->res->cookies->{cool} = { value => 'catalyst', path => '/' };
$c->res->redirect('http://www.google.com/');
}
@@ -1,7 +1,7 @@
package TestApp::Controller::Engine::Response::Errors;
use strict;
-use base 'Catalyst::Base';
+use base 'Catalyst::Controller';
sub one : Relative {
my ( $self, $c ) = @_;
@@ -1,7 +1,7 @@
package TestApp::Controller::Engine::Response::Headers;
use strict;
-use base 'Catalyst::Base';
+use base 'Catalyst::Controller';
sub one : Relative {
my ( $self, $c ) = @_;
@@ -1,7 +1,7 @@
package TestApp::Controller::Engine::Response::Large;
use strict;
-use base 'Catalyst::Base';
+use base 'Catalyst::Controller';
sub one : Relative {
my ( $self, $c ) = @_;
@@ -0,0 +1,25 @@
+package TestApp::Controller::Engine::Response::Print;
+
+use strict;
+use base 'Catalyst::Controller';
+
+sub one :Relative {
+ my ( $self, $c ) = @_;
+
+ $c->res->print("foo");
+}
+
+sub two :Relative {
+ my ( $self, $c ) = @_;
+
+ $c->res->print(qw/foo bar/);
+}
+
+sub three :Relative {
+ my ( $self, $c ) = @_;
+
+ local $, = ',';
+ $c->res->print(qw/foo bar baz/);
+}
+
+1;
@@ -1,7 +1,7 @@
package TestApp::Controller::Engine::Response::Redirect;
use strict;
-use base 'Catalyst::Base';
+use base 'Catalyst::Controller';
sub one : Relative {
my ( $self, $c ) = @_;
@@ -1,7 +1,7 @@
package TestApp::Controller::Engine::Response::Status;
use strict;
-use base 'Catalyst::Base';
+use base 'Catalyst::Controller';
sub begin : Private {
my ( $self, $c ) = @_;
@@ -7,7 +7,8 @@ package TestApp::Controller::Fork;
use strict;
use warnings;
use base 'Catalyst::Controller';
-use YAML;
+
+eval 'use YAML';
sub system : Local {
my ($self, $c, $ls) = @_;
@@ -0,0 +1,30 @@
+package TestApp::Controller::Immutable::HardToReload::Role;
+use Moose::Role; # Role metaclass does not have make_immutable..
+no Moose::Role;
+
+package TestApp::Controller::Immutable::HardToReload;
+use Moose;
+BEGIN { extends 'Catalyst::Controller' }
+no Moose;
+__PACKAGE__->meta->make_immutable;
+
+package # Standard PAUSE hiding technique
+ TestApp::Controller::Immutable::HardToReload::PAUSEHide;
+use Moose;
+BEGIN { extends 'Catalyst::Controller' }
+no Moose;
+__PACKAGE__->meta->make_immutable;
+
+# Not an inner package
+package TestApp::Controller::Immutable2;
+use Moose;
+BEGIN { extends 'Catalyst::Controller' }
+no Moose;
+__PACKAGE__->meta->make_immutable;
+
+# Not even in the app namespace
+package Frobnitz;
+use Moose;
+BEGIN { extends 'Catalyst::Controller' }
+no Moose;
+__PACKAGE__->meta->make_immutable;
@@ -0,0 +1,5 @@
+package TestApp::Controller::Immutable;
+use Moose;
+BEGIN { extends 'Catalyst::Controller' }
+no Moose;
+__PACKAGE__->meta->make_immutable;
@@ -1,7 +1,7 @@
package TestApp::Controller::Index;
use strict;
-use base 'Catalyst::Base';
+use base 'Catalyst::Controller';
sub index : Private {
my ( $self, $c ) = @_;
@@ -0,0 +1,18 @@
+package TestApp::Controller::Keyword;
+
+use strict;
+use base 'Catalyst::Controller';
+
+#
+# Due to 'actions' being used as an attribute up to cat 5.80003 using this name
+# for an action causes a weird error, as this would be called during BUILD time
+# of the Catalyst::Controller class
+#
+
+sub actions : Local {
+ my ( $self, $c ) = @_;
+ die("Call to controller action method without context! Probably naming clash") unless $c;
+ $c->res->output("Test case for using 'actions' as a catalyst action name\n");
+}
+
+1;
@@ -0,0 +1,10 @@
+package TestApp::Controller::Moose::MethodModifiers;
+use Moose;
+BEGIN { extends qw/TestApp::Controller::Moose/; }
+
+after get_attribute => sub {
+ my ($self, $c) = @_;
+ $c->response->header( 'X-Catalyst-Test-After' => 'after called' );
+};
+
+1;
@@ -0,0 +1,16 @@
+package TestApp::Controller::Moose::NoAttributes;
+use Moose;
+extends qw/Catalyst::Controller/;
+
+__PACKAGE__->config(
+ actions => {
+ test => { Local => undef }
+ }
+);
+
+sub test {
+}
+
+no Moose;
+1;
+
@@ -0,0 +1,33 @@
+package TestApp::Controller::Moose;
+
+use Moose;
+
+use namespace::clean -except => 'meta';
+
+BEGIN { extends qw/Catalyst::Controller/; }
+use MooseX::MethodAttributes; # FIXME - You need to say this if you have
+ # modifiers so that you get the correct
+ # method metaclass, why does the modifier
+ # on MODIFY_CODE_ATTRIBUTES not work.
+
+has attribute => (
+ is => 'ro',
+ default => 42,
+);
+
+sub get_attribute : Local {
+ my ($self, $c) = @_;
+ $c->response->body($self->attribute);
+}
+
+sub with_local_modifier : Local {
+ my ($self, $c) = @_;
+ $c->forward('get_attribute');
+}
+
+before with_local_modifier => sub {
+ my ($self, $c) = @_;
+ $c->response->header( 'X-Catalyst-Test-Before' => 'before called' );
+};
+
+1;
@@ -16,4 +16,6 @@ sub one :Path :Args(1) { }
sub two :Path :Args(2) { }
+sub not_def : Path { }
+
1;
@@ -1,7 +1,7 @@
package TestApp::Controller::Priorities::loc_vs_index;
use strict;
-use base 'Catalyst::Base';
+use base 'Catalyst::Controller';
sub index :Private { $_[1]->res->body( 'index' ) }
@@ -1,7 +1,7 @@
package TestApp::Controller::Priorities::locre_vs_index;
use strict;
-use base 'Catalyst::Base';
+use base 'Catalyst::Controller';
sub index :Private { $_[1]->res->body( 'index' ) }
@@ -1,7 +1,7 @@
package TestApp::Controller::Priorities::path_vs_index;
use strict;
-use base 'Catalyst::Base';
+use base 'Catalyst::Controller';
sub index :Private { $_[1]->res->body( 'index' ) }
@@ -1,7 +1,7 @@
package TestApp::Controller::Priorities::re_vs_index;
use strict;
-use base 'Catalyst::Base';
+use base 'Catalyst::Controller';
sub index :Private { $_[1]->res->body( 'index' ) }
@@ -1,7 +1,7 @@
package TestApp::Controller::Priorities;
use strict;
-use base 'Catalyst::Base';
+use base 'Catalyst::Controller';
#
# Regex vs. Local
@@ -1,9 +1,72 @@
package TestApp::Controller::Root;
-
+use strict;
+use warnings;
use base 'Catalyst::Controller';
__PACKAGE__->config->{namespace} = '';
sub chain_root_index : Chained('/') PathPart('') Args(0) { }
+sub zero : Path('0') {
+ my ( $self, $c ) = @_;
+ $c->res->header( 'X-Test-Class' => ref($self) );
+ $c->response->content_type('text/plain; charset=utf-8');
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+sub localregex : LocalRegex('^localregex$') {
+ my ( $self, $c ) = @_;
+ $c->res->header( 'X-Test-Class' => ref($self) );
+ $c->response->content_type('text/plain; charset=utf-8');
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+sub index : Private {
+ my ( $self, $c ) = @_;
+ $c->res->body('root index');
+}
+
+sub global_action : Private {
+ my ( $self, $c ) = @_;
+ $c->forward('TestApp::View::Dump::Request');
+}
+
+sub class_forward_test_method :Private {
+ my ( $self, $c ) = @_;
+ $c->response->headers->header( 'X-Class-Forward-Test-Method' => 1 );
+}
+
+sub loop_test : Local {
+ my ( $self, $c ) = @_;
+
+ for( 1..1001 ) {
+ $c->forward( 'class_forward_test_method' );
+ }
+}
+
+sub recursion_test : Local {
+ my ( $self, $c ) = @_;
+ $c->forward( 'recursion_test' );
+}
+
+sub base_href_test : Local {
+ my ( $self, $c ) = @_;
+
+ my $body = <<"EndOfBody";
+<html>
+ <head>
+ <base href="http://www.example.com/">
+ </head>
+ <body>
+ </body>
+</html>
+EndOfBody
+
+ $c->response->body($body);
+}
+
+sub end : Private {
+ my ($self,$c) = @_;
+}
+
1;
@@ -0,0 +1,10 @@
+package TestApp::DispatchType::CustomPostLoad;
+use strict;
+use warnings;
+use base qw/Catalyst::DispatchType::Path/;
+
+# Never match anything..
+sub match { }
+
+1;
+
@@ -0,0 +1,10 @@
+package TestApp::DispatchType::CustomPreLoad;
+use strict;
+use warnings;
+use base qw/Catalyst::DispatchType::Path/;
+
+# Never match anything..
+sub match { }
+
+1;
+
@@ -0,0 +1,12 @@
+package TestApp::Model::ClosuresInConfig;
+use Moose;
+use namespace::clean -except => 'meta';
+
+extends 'TestApp::Model';
+
+# Note - don't call ->config in here until the constructor calls it to
+# retrieve config, so that we get the 'copy from parent' path,
+# and ergo break due to the closure if dclone is used there..
+
+__PACKAGE__->meta->make_immutable;
+
@@ -5,8 +5,12 @@ use warnings;
use base qw/ Catalyst::Model /;
+__PACKAGE__->config( 'quux' => 'chunkybacon' );
+
sub model_foo_method { 1 }
+sub model_quux_method { shift->{quux} }
+
package TestApp::Model::Foo::Bar;
sub model_foo_bar_method_from_foo { 1 }
@@ -0,0 +1,22 @@
+package TestApp::Model::Generating;
+use Moose;
+extends 'Catalyst::Model';
+
+sub BUILD {
+ Class::MOP::Class->create(
+ 'TestApp::Model::Generated' => (
+ methods => {
+ foo => sub { 'foo' }
+ }
+ )
+ );
+}
+
+sub expand_modules {
+ return ('TestApp::Model::Generated');
+}
+
+__PACKAGE__->meta->make_immutable;
+no Moose;
+
+1;
@@ -0,0 +1,16 @@
+package TestApp::Model;
+use Moose;
+use namespace::clean -except => 'meta';
+
+extends 'Catalyst::Model';
+
+# Test a closure here, r10394 made this blow up when we clone the config down
+# onto the subclass..
+__PACKAGE__->config(
+ escape_flags => {
+ 'js' => sub { ${ $_[0] } =~ s/\'/\\\'/g; },
+ }
+);
+
+__PACKAGE__->meta->make_immutable;
+
@@ -0,0 +1,26 @@
+package TestApp::Plugin::AddDispatchTypes;
+use strict;
+use warnings;
+use MRO::Compat;
+
+sub setup_dispatcher {
+ my $class = shift;
+
+ ### Load custom DispatchTypes, as done by Catalyst::Plugin::Server
+ # There should be a waaay less ugly method for doing this,
+ # FIXME in 5.9
+ $class->next::method( @_ );
+ $class->dispatcher->preload_dispatch_types(
+ @{$class->dispatcher->preload_dispatch_types},
+ qw/ +TestApp::DispatchType::CustomPreLoad /
+ );
+ $class->dispatcher->postload_dispatch_types(
+ @{$class->dispatcher->postload_dispatch_types},
+ qw/ +TestApp::DispatchType::CustomPostLoad /
+ );
+
+ return $class;
+}
+
+1;
+
@@ -0,0 +1,18 @@
+package TestApp::Plugin::ParameterizedRole;
+
+use MooseX::Role::Parameterized;
+use namespace::autoclean;
+
+parameter method_name => (
+ isa => 'Str',
+ required => 1,
+);
+
+role {
+ my $p = shift;
+ my $method_name = $p->method_name;
+
+ method $method_name => sub { 'birne' };
+};
+
+1;
@@ -0,0 +1,14 @@
+package TestApp::RequestBaseBug;
+
+use base 'Catalyst::Request';
+
+sub uri {
+ my $self = shift;
+
+# this goes into infinite mutual recursion
+ $self->base;
+
+ $self->SUPER::uri(@_)
+}
+
+1;
@@ -0,0 +1,15 @@
+package TestApp::Role;
+use Moose::Role;
+use namespace::clean -except => 'meta';
+
+requires 'fully_qualified'; # Comes from TestApp::Plugin::FullyQualified
+
+our $SETUP_FINALIZE = 0;
+our $SETUP_DISPATCHER = 0;
+
+before 'setup_finalize' => sub { $SETUP_FINALIZE++ };
+
+before 'setup_dispatcher' => sub { $SETUP_DISPATCHER++ };
+
+1;
+
@@ -0,0 +1,11 @@
+package TestApp::View::Dump::Body;
+
+use strict;
+use base qw[TestApp::View::Dump];
+
+sub process {
+ my ( $self, $c ) = @_;
+ return $self->SUPER::process( $c, $c->request->{_body} ); # FIXME, accessor doesn't work?
+}
+
+1;
@@ -0,0 +1,12 @@
+package TestApp::View::Dump::Env;
+
+use strict;
+use base qw[TestApp::View::Dump];
+
+sub process {
+ my ( $self, $c ) = @_;
+ return $self->SUPER::process( $c, $c->engine->env );
+}
+
+1;
+
@@ -1,11 +0,0 @@
-package TestApp::View::Dump::Parameters;
-
-use strict;
-use base 'TestApp::View::Dump';
-
-sub process {
- my ( $self, $c ) = @_;
- return $self->SUPER::process( $c, $c->req->parameters );
-}
-
-1;
@@ -1,10 +1,10 @@
package TestApp::View::Dump;
use strict;
-use base 'Catalyst::Base';
+use base 'Catalyst::View';
use Data::Dumper ();
-use Scalar::Util qw(weaken);
+use Scalar::Util qw(blessed weaken);
sub dump {
my ( $self, $reference ) = @_;
@@ -28,25 +28,32 @@ sub process {
# Force processing of on-demand data
$c->prepare_body;
- # Remove context from reference if needed
- my $context = delete $reference->{_context};
-
# Remove body from reference if needed
+ $reference->{__body_type} = blessed $reference->body
+ if (blessed $reference->{_body});
my $body = delete $reference->{_body};
+ # Remove context from reference if needed
+ my $context = delete $reference->{_context};
+
if ( my $output =
- $self->dump( $reference || $c->stash->{dump} || $c->stash ) )
+ $self->dump( $reference ) )
{
$c->res->headers->content_type('text/plain');
$c->res->output($output);
- # Repair context
- $reference->{_context} = $context;
- weaken( $reference->{_context} );
-
- # Repair body
- $reference->{_body} = $body;
+ if ($context) {
+ # Repair context
+ $reference->{_context} = $context;
+ weaken( $reference->{_context} );
+ }
+
+ if ($body) {
+ # Repair body
+ delete $reference->{__body_type};
+ $reference->{_body} = $body;
+ }
return 1;
}
@@ -2,34 +2,78 @@ package TestApp;
use strict;
use Catalyst qw/
+ Test::MangleDollarUnderScore
Test::Errors
Test::Headers
Test::Plugin
Test::Inline
+TestApp::Plugin::FullyQualified
+ +TestApp::Plugin::AddDispatchTypes
+ +TestApp::Role
/;
use Catalyst::Utils;
+use Moose;
+use namespace::autoclean;
+
+# -----------
+# t/aggregate/unit_core_ctx_attr.t pukes until lazy is true
+package Greeting;
+use Moose;
+sub hello_notlazy { 'hello there' }
+sub hello_lazy { 'hello there' }
+
+package TestApp;
+has 'my_greeting_obj_notlazy' => (
+ is => 'ro',
+ isa => 'Greeting',
+ default => sub { Greeting->new() },
+ handles => [ qw( hello_notlazy ) ],
+ lazy => 0,
+);
+has 'my_greeting_obj_lazy' => (
+ is => 'ro',
+ isa => 'Greeting',
+ default => sub { Greeting->new() },
+ handles => [ qw( hello_lazy ) ],
+ lazy => 1,
+);
+# -----------
+
our $VERSION = '0.01';
-TestApp->config( name => 'TestApp', root => '/some/dir' );
+TestApp->config( name => 'TestApp', root => '/some/dir', use_request_uri_for_path => 1 );
-TestApp->setup;
+# Test bug found when re-adjusting the metaclass compat code in Moose
+# in 292360. Test added to Moose in 4b760d6, but leave this attribute
+# above ->setup so we have some generated methods to be double sure.
+has an_attribute_before_we_change_base_classes => ( is => 'ro');
-sub index : Private {
- my ( $self, $c ) = @_;
- $c->res->body('root index');
+if ($::setup_leakchecker && eval { Class::MOP::load_class('CatalystX::LeakChecker'); 1 }) {
+ with 'CatalystX::LeakChecker';
+
+ has leaks => (
+ is => 'ro',
+ default => sub { [] },
+ );
+}
+
+sub found_leaks {
+ my ($ctx, @leaks) = @_;
+ push @{ $ctx->leaks }, @leaks;
}
-sub global_action : Private {
- my ( $self, $c ) = @_;
- $c->forward('TestApp::View::Dump::Request');
+sub count_leaks {
+ my ($ctx) = @_;
+ return scalar @{ $ctx->leaks };
}
+TestApp->setup;
+
sub execute {
my $c = shift;
my $class = ref( $c->component( $_[0] ) ) || $_[0];
- my $action = "$_[1]";
+ my $action = $_[1]->reverse;
my $method;
@@ -52,7 +96,7 @@ sub execute {
@executed
);
}
-
+ no warnings 'recursion';
return $c->SUPER::execute(@_);
}
@@ -61,30 +105,12 @@ sub execute {
sub finalize_error {
my $c = shift;
- $c->NEXT::finalize_error(@_);
+ $c->next::method(@_);
$c->res->status(500);
$c->res->body( 'FATAL ERROR: ' . join( ', ', @{ $c->error } ) );
}
-sub class_forward_test_method :Private {
- my ( $self, $c ) = @_;
- $c->response->headers->header( 'X-Class-Forward-Test-Method' => 1 );
-}
-
-sub loop_test : Local {
- my ( $self, $c ) = @_;
-
- for( 1..1001 ) {
- $c->forward( 'class_forward_test_method' );
- }
-}
-
-sub recursion_test : Local {
- my ( $self, $c ) = @_;
- $c->forward( 'recursion_test' );
-}
-
{
no warnings 'redefine';
sub Catalyst::Log::error { }
@@ -96,6 +122,6 @@ package Catalyst::Plugin::Test::Inline;
use strict;
-use base qw/Catalyst::Base Class::Data::Inheritable/;
+use base qw/Class::Data::Inheritable/;
-1;
\ No newline at end of file
+1;
@@ -0,0 +1,12 @@
+package TestAppBadlyImmutable;
+use Catalyst qw/+TestPluginWithConstructor/;
+use Test::More;
+
+__PACKAGE__->setup;
+
+ok !__PACKAGE__->meta->is_immutable, 'Am not already immutable';
+__PACKAGE__->meta->make_immutable( inline_constructor => 0 );
+ok __PACKAGE__->meta->is_immutable, 'Am now immutable';
+
+1;
+
@@ -0,0 +1,21 @@
+package TestAppClassExceptionSimpleTest::Exception;
+use strict;
+use warnings;
+
+sub throw {}
+
+#########
+
+package TestAppClassExceptionSimpleTest;
+use strict;
+use warnings;
+
+use Catalyst::Utils; #< some of the scripts use Catalyst::Utils before MyApp.pm
+
+BEGIN { $Catalyst::Exception::CATALYST_EXCEPTION_CLASS = 'TestAppClassExceptionSimpleTest::Exception'; }
+
+use Catalyst;
+
+__PACKAGE__->setup;
+
+1;
@@ -0,0 +1,22 @@
+package TestAppDoubleAutoBug::Controller::Root;
+
+use base 'Catalyst::Controller';
+
+__PACKAGE__->config->{namespace} = '';
+
+sub auto : Private {
+ my ( $self, $c ) = @_;
+ ++$c->stash->{auto_count};
+ return 1;
+}
+
+sub default : Private {
+ my ( $self, $c ) = @_;
+ $c->res->body( sprintf 'default, auto=%d', $c->stash->{auto_count} );
+}
+
+sub end : Private {
+ my ($self,$c) = @_;
+}
+
+1;
@@ -18,7 +18,7 @@ __PACKAGE__->setup;
sub execute {
my $c = shift;
my $class = ref( $c->component( $_[0] ) ) || $_[0];
- my $action = "$_[1]";
+ my $action = $_[1]->reverse();
my $method;
@@ -45,15 +45,5 @@ sub execute {
return $c->SUPER::execute(@_);
}
+1;
-
-sub auto : Private {
- my ( $self, $c ) = @_;
- ++$c->stash->{auto_count};
- return 1;
-}
-
-sub default : Private {
- my ( $self, $c ) = @_;
- $c->res->body( sprintf 'default, auto=%d', $c->stash->{auto_count} );
-}
@@ -0,0 +1,48 @@
+package TestAppEncoding::Controller::Root;
+use strict;
+use warnings;
+use base 'Catalyst::Controller';
+use Test::More;
+
+__PACKAGE__->config->{namespace} = '';
+
+sub binary : Local {
+ my ($self, $c) = @_;
+ $c->res->body(do {
+ open(my $fh, '<', $c->path_to('..', '..', 'catalyst_130pix.gif')) or die $!;
+ binmode($fh);
+ local $/ = undef; <$fh>;
+ });
+}
+
+sub binary_utf8 : Local {
+ my ($self, $c) = @_;
+ $c->forward('binary');
+ my $str = $c->res->body;
+ utf8::upgrade($str);
+ ok utf8::is_utf8($str), 'Body is variable width encoded string';
+ $c->res->body($str);
+}
+
+# called by t/aggregate/catalyst_test_utf8.t
+sub utf8_non_ascii_content : Local {
+ use utf8;
+ my ($self, $c) = @_;
+
+ my $str = 'ʇsʎlɐʇɐɔ'; # 'catalyst' flipped at http://www.revfad.com/flip.html
+ ok utf8::is_utf8($str), '$str is in UTF8 internally';
+
+ # encode $str into a sequence of octets and turn off the UTF-8 flag, so that
+ # we don't get the 'Wide character in syswrite' error in Catalyst::Engine
+ utf8::encode($str);
+ ok !utf8::is_utf8($str), '$str is a sequence of octets (byte string)';
+
+ $c->res->body($str);
+}
+
+
+sub end : Private {
+ my ($self,$c) = @_;
+}
+
+1;
@@ -0,0 +1,11 @@
+package TestAppEncoding;
+use strict;
+use warnings;
+use base qw/Catalyst/;
+use Catalyst;
+
+__PACKAGE__->config(name => __PACKAGE__);
+__PACKAGE__->setup;
+
+1;
+
@@ -0,0 +1,15 @@
+package TestAppIndexDefault::Controller::Default;
+
+use base 'Catalyst::Controller';
+
+sub default : Private {
+ my ($self, $c) = @_;
+ $c->res->body('default_default');
+}
+
+sub path_one_arg : Path('/default/') Args(1) {
+ my ($self, $c) = @_;
+ $c->res->body('default_path_one_arg');
+}
+
+1;
@@ -0,0 +1,12 @@
+package TestAppIndexDefault::Controller::IndexChained;
+
+use base 'Catalyst::Controller';
+
+sub index : Chained('/') PathPart('indexchained') CaptureArgs(0) {}
+
+sub index_endpoint : Chained('index') PathPart('') Args(0) {
+ my ($self, $c) = @_;
+ $c->res->body('index_chained');
+}
+
+1;
@@ -0,0 +1,10 @@
+package TestAppIndexDefault::Controller::IndexPrivate;
+
+use base 'Catalyst::Controller';
+
+sub index : Private {
+ my ($self, $c) = @_;
+ $c->res->body('index_private');
+}
+
+1;
@@ -0,0 +1,17 @@
+package TestAppIndexDefault::Controller::Root;
+
+use base 'Catalyst::Controller';
+
+__PACKAGE__->config->{namespace} = '';
+
+sub default : Private {
+ my ($self, $c) = @_;
+ $c->res->body('default');
+}
+
+sub path_one_arg : Path('/') Args(1) {
+ my ($self, $c) = @_;
+ $c->res->body('path_one_arg');
+}
+
+1;
@@ -0,0 +1,8 @@
+package TestAppIndexDefault;
+use strict;
+use warnings;
+use Catalyst;
+
+__PACKAGE__->setup;
+
+1;
@@ -0,0 +1,24 @@
+package TestAppMatchSingleArg::Controller::Root;
+
+use strict;
+use warnings;
+use base 'Catalyst::Controller';
+
+__PACKAGE__->config->{namespace} = '';
+
+sub match_single : Path Args(1) {
+ my ($self, $c) = @_;
+ $c->res->body('Path Args(1)');
+}
+
+sub match_other : Path {
+ my ($self, $c) = @_;
+ $c->res->body('Path');
+}
+
+sub match_two : Path Args(2) {
+ my ($self, $c) = @_;
+ $c->res->body('Path Args(2)');
+}
+
+1;
@@ -0,0 +1,8 @@
+package TestAppMatchSingleArg;
+use strict;
+use warnings;
+use Catalyst;
+
+__PACKAGE__->setup;
+
+1;
@@ -0,0 +1,6 @@
+package TestAppMetaCompat::Controller::Base;
+
+use strict;
+use base qw/Catalyst::Controller/;
+
+1;
@@ -0,0 +1,8 @@
+package TestAppMetaCompat::Controller::Books;
+
+use strict;
+use base qw/TestAppMetaCompat::Controller::Base/;
+
+sub edit : Local {}
+
+1;
@@ -0,0 +1,8 @@
+package TestAppMetaCompat;
+use base qw/Catalyst/;
+
+__PACKAGE__->config(name => __PACKAGE__);
+__PACKAGE__->setup;
+
+1;
+
@@ -0,0 +1,5 @@
+package TestAppNonMooseController::Controller::Foo;
+use base qw/TestAppNonMooseController::ControllerBase/;
+
+1;
+
@@ -0,0 +1,5 @@
+package TestAppNonMooseController::ControllerBase;
+use base qw/Catalyst::Controller/;
+
+1;
+
@@ -0,0 +1,8 @@
+package TestAppNonMooseController;
+use base qw/Catalyst/;
+use Catalyst;
+
+__PACKAGE__->setup;
+
+1;
+
@@ -0,0 +1,41 @@
+package TestAppOnDemand::Controller::Body;
+
+use strict;
+use base 'Catalyst::Controller';
+
+use Data::Dump ();
+
+sub body_params : Local {
+ my ( $self, $c ) = @_;
+
+ $c->res->body( Data::Dump::dump( $c->req->body_parameters ) );
+}
+
+sub query_params : Local {
+ my ( $self, $c ) = @_;
+
+ $c->res->body( Data::Dump::dump( $c->req->query_parameters ) );
+}
+
+sub params : Local {
+ my ( $self, $c ) = @_;
+
+ $c->res->body( Data::Dump::dump( $c->req->parameters ) );
+}
+
+sub read : Local {
+ my ( $self, $c ) = @_;
+
+ # read some data
+ my @chunks;
+
+ while ( my $data = $c->read( 10_000 ) ) {
+ push @chunks, $data;
+ }
+
+ $c->res->content_type( 'text/plain');
+
+ $c->res->body( join ( '|', map { length $_ } @chunks ) );
+}
+
+1;
@@ -0,0 +1,20 @@
+package TestAppOnDemand;
+
+use strict;
+use Catalyst qw/
+ Test::Errors
+ Test::Headers
+/;
+use Catalyst::Utils;
+
+our $VERSION = '0.01';
+
+__PACKAGE__->config(
+ name => __PACKAGE__,
+ root => '/some/dir',
+ parse_on_demand => 1,
+);
+
+__PACKAGE__->setup;
+
+1;
@@ -0,0 +1,34 @@
+package TestAppOneView::Controller::Root;
+
+use base 'Catalyst::Controller';
+use Scalar::Util ();
+
+__PACKAGE__->config->{namespace} = '';
+
+sub view_no_args : Local {
+ my ( $self, $c ) = @_;
+
+ my $v = $c->view;
+
+ $c->res->body(Scalar::Util::blessed($v));
+}
+
+sub view_by_name : Local {
+ my ( $self, $c ) = @_;
+
+ my $v = $c->view($c->req->param('view'));
+
+ $c->res->body(Scalar::Util::blessed($v));
+}
+
+sub view_by_regex : Local {
+ my ( $self, $c ) = @_;
+
+ my $v_name = $c->req->param('view');
+
+ my ($v) = $c->view(qr/$v_name/);
+
+ $c->res->body(Scalar::Util::blessed($v));
+}
+
+1;
@@ -0,0 +1,13 @@
+package TestAppOneView::View::Dummy;
+
+use base 'Catalyst::View';
+
+sub COMPONENT {
+ bless {}, 'AClass'
+}
+
+package AClass;
+
+use base 'Catalyst::View';
+
+1;
@@ -0,0 +1,8 @@
+package TestAppOneView;
+use strict;
+use warnings;
+use Catalyst;
+
+__PACKAGE__->setup;
+
+1;
@@ -0,0 +1,28 @@
+use strict;
+use warnings;
+
+package TestAppPathBug;
+use strict;
+use warnings;
+use Catalyst;
+
+our $VERSION = '0.01';
+
+__PACKAGE__->config( name => 'TestAppPathBug', root => '/some/dir' );
+
+__PACKAGE__->log(TestAppPathBug::Log->new);
+__PACKAGE__->setup;
+
+sub foo : Path {
+ my ( $self, $c ) = @_;
+ $c->res->body( 'This is the foo method.' );
+}
+
+package TestAppPathBug::Log;
+use strict;
+use warnings;
+use base qw/Catalyst::Log/;
+
+sub warn {}
+
+1;
@@ -0,0 +1,12 @@
+package TestAppPluginWithConstructor::Controller::Root;
+
+use base 'Catalyst::Controller';
+
+__PACKAGE__->config->{namespace} = '';
+
+sub foo : Local {
+ my ($self, $c) = @_;
+ $c->res->body('foo');
+}
+
+1;
@@ -0,0 +1,21 @@
+# See t/plugin_new_method_backcompat.t
+package TestAppPluginWithConstructor;
+use Test::More;
+use Test::Exception;
+use Catalyst qw/+TestPluginWithConstructor/;
+use Moose;
+extends qw/Catalyst/;
+
+__PACKAGE__->setup;
+our $MODIFIER_FIRED = 0;
+
+lives_ok {
+ before 'dispatch' => sub { $MODIFIER_FIRED = 1 }
+} 'Can apply method modifier';
+no Moose;
+
+our $IS_IMMUTABLE_YET = __PACKAGE__->meta->is_immutable;
+ok !$IS_IMMUTABLE_YET, 'I am not immutable yet';
+
+1;
+
@@ -0,0 +1,19 @@
+package TestAppShowInternalActions::Controller::Root;
+use Moose;
+use namespace::autoclean;
+
+BEGIN { extends 'Catalyst::Controller' }
+
+__PACKAGE__->config(namespace => '');
+
+sub index :Path :Args(0) {
+ my ( $self, $c ) = @_;
+
+ $c->response->body( 'hello world' );
+}
+
+sub end : Action {}
+
+__PACKAGE__->meta->make_immutable;
+
+1;
@@ -0,0 +1,20 @@
+package TestAppShowInternalActions;
+use Moose;
+use namespace::autoclean;
+
+use Catalyst::Runtime 5.80;
+
+use Catalyst qw/ -Debug /; # Debug must remain on for
+ # t/live_show_internal_actions_warnings.t
+
+extends 'Catalyst';
+
+__PACKAGE__->config(
+ name => 'TestAppShowInternalActions',
+ disable_component_resolution_regex_fallback => 1,
+ show_internal_actions => 1,
+);
+
+__PACKAGE__->setup();
+
+1;
@@ -0,0 +1,16 @@
+package TestAppStats::Controller::Root;
+use strict;
+use warnings;
+use base 'Catalyst::Controller';
+
+__PACKAGE__->config->{namespace} = '';
+
+# Return log messages from previous request
+sub default : Private {
+ my ( $self, $c ) = @_;
+ $c->stats->profile("test");
+ $c->res->body(join("\n", @TestAppStats::log_messages));
+ @TestAppStats::log_messages = ();
+}
+
+1;
@@ -0,0 +1,26 @@
+use strict;
+use warnings;
+
+package TestAppStats;
+
+use Catalyst qw/
+ -Stats=1
+/;
+
+our $VERSION = '0.01';
+our @log_messages;
+
+__PACKAGE__->config( name => 'TestAppStats', root => '/some/dir' );
+
+__PACKAGE__->log(TestAppStats::Log->new);
+
+__PACKAGE__->setup;
+
+package TestAppStats::Log;
+use base qw/Catalyst::Log/;
+
+sub info { push(@TestAppStats::log_messages, @_); }
+sub debug { push(@TestAppStats::log_messages, @_); }
+
+1;
+
@@ -0,0 +1,14 @@
+package TestAppToTestScripts;
+use strict;
+use warnings;
+use Carp;
+
+our @RUN_ARGS;
+
+sub run {
+ @RUN_ARGS = @_;
+ 1; # Does this work?
+}
+
+1;
+
@@ -0,0 +1,22 @@
+package TestApp;
+
+use strict;
+use warnings;
+
+use Catalyst::Runtime 5.70;
+
+use base qw/Catalyst/;
+
+use Catalyst;
+
+__PACKAGE__->setup();
+
+sub _test {
+ my $self = shift;
+ $self->_method_which_does_not_exist;
+}
+
+__PACKAGE__->_test;
+
+1;
+
@@ -0,0 +1,17 @@
+package TestAppViewWarnings::Controller::Root;
+use strict;
+use warnings;
+use base 'Catalyst::Controller';
+
+__PACKAGE__->config->{namespace} = '';
+
+# Return log messages from previous request
+sub index :Path Args() {}
+
+sub end : Action {
+ my ($self, $c) = @_;
+ $c->view; # Cause view lookup and ergo warning we are testing.
+ $c->res->body('foo');
+}
+
+1;
@@ -0,0 +1,22 @@
+use strict;
+use warnings;
+
+package TestAppViewWarnings;
+
+use Catalyst;
+
+our @log_messages;
+
+__PACKAGE__->config( name => 'TestAppWarnings', root => '/some/dir', default_view => "DoesNotExist" );
+
+__PACKAGE__->log(TestAppViewWarnings::Log->new);
+
+__PACKAGE__->setup;
+
+package TestAppViewWarnings::Log;
+
+use base qw/Catalyst::Log/;
+sub warn { push(@TestAppViewWarnings::log_messages, @_[1..$#_]); }
+
+1;
+
@@ -0,0 +1,17 @@
+package TestAppWithMeta::Controller::Root;
+use base qw/Catalyst::Controller/; # N.B. Do not convert to Moose, so we do not
+ # have a metaclass instance!
+
+__PACKAGE__->config( namespace => '' );
+
+no warnings 'redefine';
+sub meta { 'fnar' }
+use warnings 'redefine';
+
+sub default : Private {
+ my ($self, $c) = @_;
+ $c->res->body($self->meta);
+}
+
+1;
+
@@ -0,0 +1,13 @@
+package TestAppWithMeta;
+use strict;
+use warnings;
+use Catalyst;
+
+no warnings 'redefine';
+sub meta {}
+use warnings 'redefine';
+
+__PACKAGE__->setup;
+
+1;
+
@@ -0,0 +1,17 @@
+# See t/plugin_new_method_backcompat.t
+package Class::Accessor::Fast;
+use strict;
+use warnings;
+
+sub new {
+ my $class = shift;
+ return bless $_[0], $class;
+}
+
+package TestPluginWithConstructor;
+use strict;
+use warnings;
+use base qw/Class::Accessor::Fast/;
+
+1;
+
@@ -1,110 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-our $iters;
-
-BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
-
-use Test::More tests => 28 * $iters;
-use Catalyst::Test 'TestApp';
-
-if ( $ENV{CAT_BENCHMARK} ) {
- require Benchmark;
- Benchmark::timethis( $iters, \&run_tests );
-}
-else {
- for ( 1 .. $iters ) {
- run_tests();
- }
-}
-
-sub run_tests {
- {
- ok( my $response = request('http://localhost/action_action_one'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'),
- 'action_action_one', 'Test Action' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::Action',
- 'Test Class'
- );
- is( $response->header('X-Action'), 'works' );
- like(
- $response->content,
- qr/^bless\( .* 'Catalyst::Request' \)$/s,
- 'Content is a serialized Catalyst::Request'
- );
- }
-
- {
- ok( my $response = request('http://localhost/action_action_two'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'),
- 'action_action_two', 'Test Action' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::Action',
- 'Test Class'
- );
- is( $response->header('X-Action-After'), 'awesome' );
- like(
- $response->content,
- qr/^bless\( .* 'Catalyst::Request' \)$/s,
- 'Content is a serialized Catalyst::Request'
- );
- }
-
- {
- ok(
- my $response =
- request('http://localhost/action_action_three/one/two'),
- 'Request'
- );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'),
- 'action_action_three', 'Test Action' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::Action',
- 'Test Class'
- );
- is( $response->header('X-TestAppActionTestBefore'), 'one' );
- like(
- $response->content,
- qr/^bless\( .* 'Catalyst::Request' \)$/s,
- 'Content is a serialized Catalyst::Request'
- );
- }
-
- {
- ok( my $response = request('http://localhost/action_action_four'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'),
- 'action_action_four', 'Test Action' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::Action',
- 'Test Class'
- );
- is( $response->header('X-TestAppActionTestMyAction'), 'MyAction works' );
- like(
- $response->content,
- qr/^bless\( .* 'Catalyst::Request' \)$/s,
- 'Content is a serialized Catalyst::Request'
- );
- }
-
-}
@@ -1,136 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-our $iters;
-
-BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
-
-use Test::More tests => 18*$iters;
-use Catalyst::Test 'TestApp';
-
-if ( $ENV{CAT_BENCHMARK} ) {
- require Benchmark;
- Benchmark::timethis( $iters, \&run_tests );
-
- # new dispatcher:
- # 11 wallclock secs (10.14 usr + 0.20 sys = 10.34 CPU) @ 15.18/s (n=157)
- # old dispatcher (r1486):
- # 11 wallclock secs (10.34 usr + 0.20 sys = 10.54 CPU) @ 13.76/s (n=145)
-}
-else {
- for ( 1 .. $iters ) {
- run_tests();
- }
-}
-
-sub run_tests {
- # test auto + local method
- {
- my @expected = qw[
- TestApp::Controller::Action::Auto->begin
- TestApp::Controller::Action::Auto->auto
- TestApp::Controller::Action::Auto->one
- TestApp->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/action/auto/one'), 'auto + local' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, 'one', 'Content OK' );
- }
-
- # test auto + default
- {
- my @expected = qw[
- TestApp::Controller::Action::Auto->begin
- TestApp::Controller::Action::Auto->auto
- TestApp::Controller::Action::Auto->default
- TestApp->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/action/auto/anything'), 'auto + default' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, 'default', 'Content OK' );
- }
-
- # test auto + auto + local
- {
- my @expected = qw[
- TestApp::Controller::Action::Auto::Deep->begin
- TestApp::Controller::Action::Auto->auto
- TestApp::Controller::Action::Auto::Deep->auto
- TestApp::Controller::Action::Auto::Deep->one
- TestApp->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/action/auto/deep/one'), 'auto + auto + local' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, 'deep one', 'Content OK' );
- }
-
- # test auto + auto + default
- {
- my @expected = qw[
- TestApp::Controller::Action::Auto::Deep->begin
- TestApp::Controller::Action::Auto->auto
- TestApp::Controller::Action::Auto::Deep->auto
- TestApp::Controller::Action::Auto::Deep->default
- TestApp->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/action/auto/deep/anything'), 'auto + auto + default' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, 'deep default', 'Content OK' );
- }
-
- # test auto + failing auto + local + end
- {
- my @expected = qw[
- TestApp::Controller::Action::Auto::Abort->begin
- TestApp::Controller::Action::Auto->auto
- TestApp::Controller::Action::Auto::Abort->auto
- TestApp::Controller::Action::Auto::Abort->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/action/auto/abort/one'), 'auto + failing auto + local' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, 'abort end', 'Content OK' );
- }
-
- # test auto + default (bug on invocation of default twice)
- {
- my @expected = qw[
- TestApp::Controller::Action::Auto::Default->begin
- TestApp::Controller::Action::Auto->auto
- TestApp::Controller::Action::Auto::Default->auto
- TestApp::Controller::Action::Auto::Default->default
- TestApp::Controller::Action::Auto::Default->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/action/auto/default/moose'), 'auto + default' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, 'default (auto: 1)', 'Content OK' );
- }
-}
@@ -1,53 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-our $iters;
-
-BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
-
-use Test::More tests => 7*$iters;
-use Catalyst::Test 'TestApp';
-
-if ( $ENV{CAT_BENCHMARK} ) {
- require Benchmark;
- Benchmark::timethis( $iters, \&run_tests );
-}
-else {
- for ( 1 .. $iters ) {
- run_tests();
- }
-}
-
-sub run_tests {
-
- {
- my @expected = qw[
- TestApp::Controller::Action::Begin->begin
- TestApp::Controller::Action::Begin->default
- TestApp::View::Dump::Request->process
- TestApp->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/action/begin'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'), 'default', 'Test Action' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::Begin',
- 'Test Class'
- );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- like( $response->content, qr/'Catalyst::Request'/,
- 'Content is a serialized Catalyst::Request' );
- }
-}
@@ -1,831 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-our $iters;
-
-BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
-
-use Test::More tests => 118*$iters;
-use Catalyst::Test 'TestApp';
-
-if ( $ENV{CAT_BENCHMARK} ) {
- require Benchmark;
- Benchmark::timethis( $iters, \&run_tests );
-}
-else {
- for ( 1 .. $iters ) {
- run_tests($_);
- }
-}
-
-sub run_tests {
- my ($run_number) = @_;
-
- #
- # This is a simple test where the parent and child actions are
- # within the same controller.
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained->begin
- TestApp::Controller::Action::Chained->foo
- TestApp::Controller::Action::Chained->endpoint
- TestApp::Controller::Action::Chained->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/chained/foo/1/end/2'), 'chained + local endpoint' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, '1; 2', 'Content OK' );
- }
-
- #
- # This makes sure the above isn't found if the argument for the
- # end action isn't supplied.
- #
- {
- my $expected = undef;
-
- ok( my $response = request('http://localhost/chained/foo/1/end'),
- 'chained + local endpoint; missing last argument' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->code, 500, 'Status OK' );
- }
-
- #
- # Tests the case when the child action is placed in a subcontroller.
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained->begin
- TestApp::Controller::Action::Chained->foo
- TestApp::Controller::Action::Chained::Foo->spoon
- TestApp::Controller::Action::Chained->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/chained/foo/1/spoon'), 'chained + subcontroller endpoint' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, '1; ', 'Content OK' );
- }
-
- #
- # Tests if the relative specification (e.g.: Chained('bar') ) works
- # as expected.
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained->begin
- TestApp::Controller::Action::Chained->bar
- TestApp::Controller::Action::Chained->finale
- TestApp::Controller::Action::Chained->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/chained/bar/1/spoon'), 'chained + relative endpoint' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, '; 1, spoon', 'Content OK' );
- }
-
- #
- # Just a test for multiple arguments.
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained->begin
- TestApp::Controller::Action::Chained->foo2
- TestApp::Controller::Action::Chained->endpoint2
- TestApp::Controller::Action::Chained->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/chained/foo2/10/20/end2/15/25'),
- 'chained + local (2 args each)' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, '10, 20; 15, 25', 'Content OK' );
- }
-
- #
- # The first three-chain test tries to call the action with :Args(1)
- # specification. There's also a one action with a :CaptureArgs(1)
- # attribute, that should not be dispatched to.
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained->begin
- TestApp::Controller::Action::Chained->one_end
- TestApp::Controller::Action::Chained->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/chained/one/23'),
- 'three-chain (only first)' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, '; 23', 'Content OK' );
- }
-
- #
- # This is the second three-chain test, it goes for the action that
- # handles "/one/$cap/two/$arg1/$arg2" paths. Should be the two action
- # having :Args(2), not the one having :CaptureArgs(2).
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained->begin
- TestApp::Controller::Action::Chained->one
- TestApp::Controller::Action::Chained->two_end
- TestApp::Controller::Action::Chained->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/chained/one/23/two/23/46'),
- 'three-chain (up to second)' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, '23; 23, 46', 'Content OK' );
- }
-
- #
- # Last of the three-chain tests. Has no concurrent action with :CaptureArgs
- # and is more thought to simply test the chain as a whole and the 'two'
- # action specifying :CaptureArgs.
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained->begin
- TestApp::Controller::Action::Chained->one
- TestApp::Controller::Action::Chained->two
- TestApp::Controller::Action::Chained->three_end
- TestApp::Controller::Action::Chained->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/chained/one/23/two/23/46/three/1/2/3'),
- 'three-chain (all three)' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, '23, 23, 46; 1, 2, 3', 'Content OK' );
- }
-
- #
- # Tests dispatching on number of arguments for :Args. This should be
- # dispatched to the action expecting one argument.
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained->begin
- TestApp::Controller::Action::Chained->multi1
- TestApp::Controller::Action::Chained->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/chained/multi/23'),
- 'multi-action (one arg)' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, '; 23', 'Content OK' );
- }
-
- #
- # Belongs to the former test and goes for the action expecting two arguments.
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained->begin
- TestApp::Controller::Action::Chained->multi2
- TestApp::Controller::Action::Chained->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/chained/multi/23/46'),
- 'multi-action (two args)' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, '; 23, 46', 'Content OK' );
- }
-
- #
- # Dispatching on argument count again, this time we provide too many
- # arguments, so dispatching should fail.
- #
- {
- my $expected = undef;
-
- ok( my $response = request('http://localhost/chained/multi/23/46/67'),
- 'multi-action (three args, should lead to error)' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->code, 500, 'Status OK' );
- }
-
- #
- # This tests the case when an action says it's the child of an action in
- # a subcontroller.
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained->begin
- TestApp::Controller::Action::Chained::Foo->higher_root
- TestApp::Controller::Action::Chained->higher_root
- TestApp::Controller::Action::Chained->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/chained/higher_root/23/bar/11'),
- 'root higher than child' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, '23; 11', 'Content OK' );
- }
-
- #
- # Just a more complex version of the former test. It tests if a controller ->
- # subcontroller -> controller dispatch works.
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained->begin
- TestApp::Controller::Action::Chained->pcp1
- TestApp::Controller::Action::Chained::Foo->pcp2
- TestApp::Controller::Action::Chained->pcp3
- TestApp::Controller::Action::Chained->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/chained/pcp1/1/pcp2/2/pcp3/3'),
- 'parent -> child -> parent' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, '1, 2; 3', 'Content OK' );
- }
-
- #
- # Tests dispatch on capture number. This test is for a one capture action.
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained->begin
- TestApp::Controller::Action::Chained->multi_cap1
- TestApp::Controller::Action::Chained->multi_cap_end1
- TestApp::Controller::Action::Chained->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/chained/multi_cap/1/baz'),
- 'dispatch on capture num 1' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, '1; ', 'Content OK' );
- }
-
- #
- # Belongs to the former test. This one goes for the action expecting two
- # captures.
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained->begin
- TestApp::Controller::Action::Chained->multi_cap2
- TestApp::Controller::Action::Chained->multi_cap_end2
- TestApp::Controller::Action::Chained->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/chained/multi_cap/1/2/baz'),
- 'dispatch on capture num 2' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, '1, 2; ', 'Content OK' );
- }
-
- #
- # Tests the priority of a slurpy arguments action (with :Args) against
- # two actions chained together. The two actions should win.
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained->begin
- TestApp::Controller::Action::Chained->priority_a2
- TestApp::Controller::Action::Chained->priority_a2_end
- TestApp::Controller::Action::Chained->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/chained/priority_a/1/end/2'),
- 'priority - slurpy args vs. parent/child' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, '1; 2', 'Content OK' );
- }
-
- #
- # This belongs to the former test but tests if two chained actions have
- # priority over an action with the exact arguments.
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained->begin
- TestApp::Controller::Action::Chained->priority_b2
- TestApp::Controller::Action::Chained->priority_b2_end
- TestApp::Controller::Action::Chained->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/chained/priority_b/1/end/2'),
- 'priority - fixed args vs. parent/child' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, '1; 2', 'Content OK' );
- }
-
- #
- # This belongs to the former test but tests if two chained actions have
- # priority over an action with one child action not having the Args() attr set.
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained->begin
- TestApp::Controller::Action::Chained->priority_c1
- TestApp::Controller::Action::Chained->priority_c2_xyz
- TestApp::Controller::Action::Chained->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/chained/priority_c/1/xyz/'),
- 'priority - no Args() order mismatch' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, '1; ', 'Content OK' );
- }
-
- #
- # Test dispatching between two controllers that are on the same level and
- # therefor have no parent/child relationship.
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained->begin
- TestApp::Controller::Action::Chained::Bar->cross1
- TestApp::Controller::Action::Chained::Foo->cross2
- TestApp::Controller::Action::Chained->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/chained/cross/1/end/2'),
- 'cross controller w/o par/child relation' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, '1; 2', 'Content OK' );
- }
-
- #
- # This is for testing if the arguments got passed to the actions
- # correctly.
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained->begin
- TestApp::Controller::Action::Chained::PassedArgs->first
- TestApp::Controller::Action::Chained::PassedArgs->second
- TestApp::Controller::Action::Chained::PassedArgs->third
- TestApp::Controller::Action::Chained::PassedArgs->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/chained/passedargs/a/1/b/2/c/3'),
- 'Correct arguments passed to actions' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, '1; 2; 3', 'Content OK' );
- }
-
- #
- # The :Args attribute is optional, we check the action not specifying
- # it with these tests.
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained->begin
- TestApp::Controller::Action::Chained->opt_args
- TestApp::Controller::Action::Chained->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/chained/opt_args/1/2/3'),
- 'Optional :Args attribute working' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, '; 1, 2, 3', 'Content OK' );
- }
-
- #
- # Tests for optional PathPart attribute.
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained->begin
- TestApp::Controller::Action::Chained->opt_pp_start
- TestApp::Controller::Action::Chained->opt_pathpart
- TestApp::Controller::Action::Chained->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/chained/optpp/1/opt_pathpart/2'),
- 'Optional :PathName attribute working' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, '1; 2', 'Content OK' );
- }
-
- #
- # Tests for optional PathPart *and* Args attributes.
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained->begin
- TestApp::Controller::Action::Chained->opt_all_start
- TestApp::Controller::Action::Chained->oa
- TestApp::Controller::Action::Chained->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/chained/optall/1/oa/2/3'),
- 'Optional :PathName *and* :Args attributes working' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, '1; 2, 3', 'Content OK' );
- }
-
- #
- # Test if :Chained is the same as :Chained('/')
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained->begin
- TestApp::Controller::Action::Chained->rootdef
- TestApp::Controller::Action::Chained->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/chained/rootdef/23'),
- ":Chained is the same as :Chained('/')" );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, '; 23', 'Content OK' );
- }
-
- #
- # Test if :Chained('.') is working
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained->begin
- TestApp::Controller::Action::Chained->parentchain
- TestApp::Controller::Action::Chained::ParentChain->child
- TestApp::Controller::Action::Chained->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/chained/parentchain/1/child/2'),
- ":Chained('.') chains to parent controller action" );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, '1; 2', 'Content OK' );
- }
-
- #
- # Test behaviour of auto actions returning '1' for the chain.
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained->begin
- TestApp::Controller::Action::Chained::Auto->auto
- TestApp::Controller::Action::Chained::Auto::Foo->auto
- TestApp::Controller::Action::Chained::Auto->foo
- TestApp::Controller::Action::Chained::Auto::Foo->fooend
- TestApp::Controller::Action::Chained->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/chained/autochain1/1/fooend/2'),
- "Behaviour when auto returns 1 correct" );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, '1; 2', 'Content OK' );
- }
-
- #
- # Test behaviour of auto actions returning '0' for the chain.
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained->begin
- TestApp::Controller::Action::Chained::Auto->auto
- TestApp::Controller::Action::Chained::Auto::Bar->auto
- TestApp::Controller::Action::Chained->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/chained/autochain2/1/barend/2'),
- "Behaviour when auto returns 0 correct" );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, '1; 2', 'Content OK' );
- }
-
- #
- # Test what auto actions are run when namespaces are changed
- # horizontally.
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained->begin
- TestApp::Controller::Action::Chained::Auto->auto
- TestApp::Controller::Action::Chained::Auto::Foo->auto
- TestApp::Controller::Action::Chained::Auto::Bar->crossloose
- TestApp::Controller::Action::Chained::Auto::Foo->crossend
- TestApp::Controller::Action::Chained->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/chained/auto_cross/1/crossend/2'),
- "Correct auto actions are run on cross controller dispatch" );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, '1; 2', 'Content OK' );
- }
-
- #
- # Test forwarding from auto action in chain dispatch.
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained->begin
- TestApp::Controller::Action::Chained::Auto->auto
- TestApp::Controller::Action::Chained::Auto::Forward->auto
- TestApp::Controller::Action::Chained::Auto->fw3
- TestApp::Controller::Action::Chained::Auto->fw1
- TestApp::Controller::Action::Chained::Auto::Forward->forwardend
- TestApp::Controller::Action::Chained->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/chained/auto_forward/1/forwardend/2'),
- "Forwarding out of auto in chain" );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, '1; 2', 'Content OK' );
- }
-
- #
- # Detaching out of the auto action of a chain.
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained->begin
- TestApp::Controller::Action::Chained::Auto->auto
- TestApp::Controller::Action::Chained::Auto::Detach->auto
- TestApp::Controller::Action::Chained::Auto->fw3
- TestApp::Controller::Action::Chained->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/chained/auto_detach/1/detachend/2'),
- "Detaching out of auto in chain" );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, '1; 2', 'Content OK' );
- }
-
- #
- # Test forwarding from auto action in chain dispatch.
- #
- {
- my $expected = undef;
-
- ok( my $response = request('http://localhost/chained/loose/23'),
- "Loose end is not callable" );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->code, 500, 'Status OK' );
- }
-
- #
- # Test forwarding out of a chain.
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained->begin
- TestApp::Controller::Action::Chained->chain_fw_a
- TestApp::Controller::Action::Chained->fw_dt_target
- TestApp::Controller::Action::Chained->chain_fw_b
- TestApp::Controller::Action::Chained->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/chained/chain_fw/1/end/2'),
- "Forwarding out a chain" );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, '1; 2', 'Content OK' );
- }
-
- #
- # Test detaching out of a chain.
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained->begin
- TestApp::Controller::Action::Chained->chain_dt_a
- TestApp::Controller::Action::Chained->fw_dt_target
- TestApp::Controller::Action::Chained->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/chained/chain_dt/1/end/2'),
- "Forwarding out a chain" );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, '1; 2', 'Content OK' );
- }
-
- #
- # Tests that an uri_for to a chained root index action
- # returns the right value.
- #
- {
- ok( my $response = request(
- 'http://localhost/action/chained/to_root' ),
- 'uri_for with chained root action as arg' );
- like( $response->content,
- qr(URI:https?://[^/]+/),
- 'Correct URI generated' );
- }
-
- #
- # Test interception of recursive chains. This test was added because at
- # one point during the :Chained development, Catalyst used to hang on
- # recursive chains.
- #
- {
- eval { require 'TestAppChainedRecursive.pm' };
- if ($run_number == 1) {
- ok( ! $@, "Interception of recursive chains" );
- }
- else { pass( "Interception of recursive chains already tested" ) }
- }
-
- #
- # Test failure of absolute path part arguments.
- #
- {
- eval { require 'TestAppChainedAbsolutePathPart.pm' };
- if ($run_number == 1) {
- like( $@, qr(foo/foo),
- "Usage of absolute path part argument emits error" );
- }
- else { pass( "Error on absolute path part arguments already tested" ) }
- }
-
- #
- # Test chained actions in the root controller
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained::Root->rootsub
- TestApp::Controller::Action::Chained::Root->endpointsub
- TestApp->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/rootsub/1/endpointsub/2'), 'chained in root namespace' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, '', 'Content OK' );
- }
-
- #
- # Complex path with multiple empty pathparts
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained->begin
- TestApp::Controller::Action::Chained->mult_nopp_base
- TestApp::Controller::Action::Chained->mult_nopp_all
- TestApp::Controller::Action::Chained->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/chained/mult_nopp'),
- "Complex path with multiple empty pathparts" );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, '; ', 'Content OK' );
- }
-
- #
- # Higher Args() hiding more specific CaptureArgs chains sections
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained->begin
- TestApp::Controller::Action::Chained->cc_base
- TestApp::Controller::Action::Chained->cc_link
- TestApp::Controller::Action::Chained->cc_anchor
- TestApp::Controller::Action::Chained->end
- ];
-
- my $expected = join ', ', @expected;
-
- ok( my $response = request('http://localhost/chained/choose_capture/anchor.html'),
- 'Choose between an early Args() and a later more ideal chain' );
- is( $response->header('X-Catalyst-Executed') => $expected, 'Executed actions');
- is( $response->content => '; ', 'Content OK' );
- }
-
- #
- # Less specific chain not being seen correctly due to earlier looser capture
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained->begin
- TestApp::Controller::Action::Chained->cc_base
- TestApp::Controller::Action::Chained->cc_b
- TestApp::Controller::Action::Chained->cc_b_link
- TestApp::Controller::Action::Chained->cc_b_anchor
- TestApp::Controller::Action::Chained->end
- ];
-
- my $expected = join ', ', @expected;
-
- ok( my $response = request('http://localhost/chained/choose_capture/b/a/anchor.html'),
- 'Choose between a more specific chain and an earlier looser one' );
- is( $response->header('X-Catalyst-Executed') => $expected, 'Executed actions');
- is( $response->content => 'a; ', 'Content OK' );
- }
-
- #
- # Check we get the looser one when it's the correct match
- #
- {
- my @expected = qw[
- TestApp::Controller::Action::Chained->begin
- TestApp::Controller::Action::Chained->cc_base
- TestApp::Controller::Action::Chained->cc_a
- TestApp::Controller::Action::Chained->cc_a_link
- TestApp::Controller::Action::Chained->cc_a_anchor
- TestApp::Controller::Action::Chained->end
- ];
-
- my $expected = join ', ', @expected;
-
- ok( my $response = request('http://localhost/chained/choose_capture/a/a/anchor.html'),
- 'Choose between a more specific chain and an earlier looser one' );
- is( $response->header('X-Catalyst-Executed') => $expected, 'Executed actions');
- is( $response->content => 'a; anchor.html', 'Content OK' );
- }
-
-}
@@ -1,96 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-our $iters;
-
-BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
-
-use Test::More tests => 16 * $iters;
-use Catalyst::Test 'TestApp';
-
-if ( $ENV{CAT_BENCHMARK} ) {
- require Benchmark;
- Benchmark::timethis( $iters, \&run_tests );
-}
-else {
- for ( 1 .. $iters ) {
- run_tests();
- }
-}
-
-sub run_tests {
- {
- my @expected = qw[
- TestApp::Controller::Action::Default->begin
- TestApp::Controller::Action::Default->default
- TestApp::View::Dump::Request->process
- TestApp->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/action/default'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'), 'default', 'Test Action' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::Default',
- 'Test Class'
- );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- like(
- $response->content,
- qr/^bless\( .* 'Catalyst::Request' \)$/s,
- 'Content is a serialized Catalyst::Request'
- );
-
- ok( $response = request('http://localhost/foo/bar/action'), 'Request' );
- is( $response->code, 500, 'Invalid URI returned 500' );
- }
-
- # test that args are passed properly to default
- {
- my $creq;
- my $expected = [qw/action default arg1 arg2/];
-
- ok( my $response = request('http://localhost/action/default/arg1/arg2'),
- 'Request' );
- ok(
- eval '$creq = ' . $response->content,
- 'Unserialize Catalyst::Request'
- );
- is_deeply( $creq->{arguments}, $expected, 'Arguments ok' );
- }
-
-
- # Test that /foo and /foo/ both do the same thing
- {
- my @expected = qw[
- TestApp::Controller::Action->begin
- TestApp::Controller::Action->default
- TestApp->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/action'), 'Request' );
- is( $response->header('X-Catalyst-Executed'),
- $expected,
- 'Executed actions for /action'
- );
-
- ok( $response = request('http://localhost/action/'), 'Request' );
- is( $response->header('X-Catalyst-Executed'),
- $expected,
- 'Executed actions for /action/'
- );
- }
-}
@@ -1,100 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-our $iters;
-
-BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
-
-use Test::More tests => 18*$iters;
-use Catalyst::Test 'TestApp';
-
-if ( $ENV{CAT_BENCHMARK} ) {
- require Benchmark;
- Benchmark::timethis( $iters, \&run_tests );
-}
-else {
- for ( 1 .. $iters ) {
- run_tests();
- }
-}
-
-sub run_tests {
- {
- my @expected = qw[
- TestApp::Controller::Action::Detach->begin
- TestApp::Controller::Action::Detach->one
- TestApp::Controller::Action::Detach->two
- TestApp::View::Dump::Request->process
- TestApp->end
- ];
-
- my $expected = join( ", ", @expected );
-
- # Test detach to chain of actions.
- ok( my $response = request('http://localhost/action/detach/one'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'),
- 'action/detach/one', 'Test Action' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::Detach',
- 'Test Class'
- );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- }
-
- {
- my @expected = qw[
- TestApp::Controller::Action::Detach->begin
- TestApp::Controller::Action::Detach->path
- TestApp::Controller::Action::Detach->two
- TestApp::View::Dump::Request->process
- TestApp->end
- ];
-
- my $expected = join( ", ", @expected );
-
- # Test detach to chain of actions.
- ok( my $response = request('http://localhost/action/detach/path'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'),
- 'action/detach/path', 'Test Action' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::Detach',
- 'Test Class'
- );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- }
-
- {
- ok(
- my $response =
- request('http://localhost/action/detach/with_args/old'),
- 'Request with args'
- );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content, 'new' );
- }
-
- {
- ok(
- my $response = request(
- 'http://localhost/action/detach/with_method_and_args/old'),
- 'Request with args and method'
- );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content, 'new' );
- }
-}
@@ -1,54 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-our $iters;
-
-BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
-
-use Test::More tests => 7*$iters;
-use Catalyst::Test 'TestApp';
-
-if ( $ENV{CAT_BENCHMARK} ) {
- require Benchmark;
- Benchmark::timethis( $iters, \&run_tests );
-}
-else {
- for ( 1 .. $iters ) {
- run_tests();
- }
-}
-
-sub run_tests {
- {
- my @expected = qw[
- TestApp::Controller::Action::End->begin
- TestApp::Controller::Action::End->default
- TestApp::View::Dump::Request->process
- TestApp::Controller::Action::End->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/action/end'), 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'), 'default', 'Test Action' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::End',
- 'Test Class'
- );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- like(
- $response->content,
- qr/^bless\( .* 'Catalyst::Request' \)$/s,
- 'Content is a serialized Catalyst::Request'
- );
- }
-}
@@ -1,238 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-our $iters;
-
-BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
-
-use Test::More tests => 47 * $iters;
-use Catalyst::Test 'TestApp';
-
-if ( $ENV{CAT_BENCHMARK} ) {
- require Benchmark;
- Benchmark::timethis( $iters, \&run_tests );
-}
-else {
- for ( 1 .. $iters ) {
- run_tests();
- }
-}
-
-sub run_tests {
- {
- my @expected = qw[
- TestApp::Controller::Action::Forward->begin
- TestApp::Controller::Action::Forward->one
- TestApp::Controller::Action::Forward->two
- TestApp::Controller::Action::Forward->three
- TestApp::Controller::Action::Forward->four
- TestApp::Controller::Action::Forward->five
- TestApp::View::Dump::Request->process
- TestApp->end
- ];
-
- my $expected = join( ", ", @expected );
-
- # Test forward to global private action
- ok( my $response = request('http://localhost/action/forward/global'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'),
- 'action/forward/global', 'Main Class Action' );
-
- # Test forward to chain of actions.
- ok( $response = request('http://localhost/action/forward/one'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'),
- 'action/forward/one', 'Test Action' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::Forward',
- 'Test Class'
- );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- like(
- $response->content,
- qr/^bless\( .* 'Catalyst::Request' \)$/s,
- 'Content is a serialized Catalyst::Request'
- );
- }
-
- {
- my @expected = qw[
- TestApp::Controller::Action::Forward->begin
- TestApp::Controller::Action::Forward->jojo
- TestApp::Controller::Action::Forward->one
- TestApp::Controller::Action::Forward->two
- TestApp::Controller::Action::Forward->three
- TestApp::Controller::Action::Forward->four
- TestApp::Controller::Action::Forward->five
- TestApp::View::Dump::Request->process
- TestApp::Controller::Action::Forward->three
- TestApp::Controller::Action::Forward->four
- TestApp::Controller::Action::Forward->five
- TestApp::View::Dump::Request->process
- TestApp->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/action/forward/jojo'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'),
- 'action/forward/jojo', 'Test Action' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::Forward',
- 'Test Class'
- );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- like(
- $response->content,
- qr/^bless\( .* 'Catalyst::Request' \)$/s,
- 'Content is a serialized Catalyst::Request'
- );
- }
-
- {
- ok(
- my $response =
- request('http://localhost/action/forward/with_args/old'),
- 'Request with args'
- );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content, 'old' );
- }
-
- {
- ok(
- my $response = request(
- 'http://localhost/action/forward/with_method_and_args/old'),
- 'Request with args and method'
- );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content, 'old' );
- }
-
- # test forward with embedded args
- {
- ok(
- my $response =
- request('http://localhost/action/forward/args_embed_relative'),
- 'Request'
- );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content, 'ok' );
- }
-
- {
- ok(
- my $response =
- request('http://localhost/action/forward/args_embed_absolute'),
- 'Request'
- );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content, 'ok' );
- }
- {
- my @expected = qw[
- TestApp::Controller::Action::TestRelative->begin
- TestApp::Controller::Action::TestRelative->relative
- TestApp::Controller::Action::Forward->one
- TestApp::Controller::Action::Forward->two
- TestApp::Controller::Action::Forward->three
- TestApp::Controller::Action::Forward->four
- TestApp::Controller::Action::Forward->five
- TestApp::View::Dump::Request->process
- TestApp->end
- ];
-
- my $expected = join( ", ", @expected );
-
- # Test forward to chain of actions.
- ok( my $response = request('http://localhost/action/relative/relative'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'),
- 'action/relative/relative', 'Test Action' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::TestRelative',
- 'Test Class'
- );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- like(
- $response->content,
- qr/^bless\( .* 'Catalyst::Request' \)$/s,
- 'Content is a serialized Catalyst::Request'
- );
- }
- {
- my @expected = qw[
- TestApp::Controller::Action::TestRelative->begin
- TestApp::Controller::Action::TestRelative->relative_two
- TestApp::Controller::Action::Forward->one
- TestApp::Controller::Action::Forward->two
- TestApp::Controller::Action::Forward->three
- TestApp::Controller::Action::Forward->four
- TestApp::Controller::Action::Forward->five
- TestApp::View::Dump::Request->process
- TestApp->end
- ];
-
- my $expected = join( ", ", @expected );
-
- # Test forward to chain of actions.
- ok(
- my $response =
- request('http://localhost/action/relative/relative_two'),
- 'Request'
- );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is(
- $response->header('X-Catalyst-Action'),
- 'action/relative/relative_two',
- 'Test Action'
- );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::TestRelative',
- 'Test Class'
- );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- like(
- $response->content,
- qr/^bless\( .* 'Catalyst::Request' \)$/s,
- 'Content is a serialized Catalyst::Request'
- );
- }
-
- # test class forwards
- {
- ok(
- my $response = request(
- 'http://localhost/action/forward/class_forward_test_action'),
- 'Request'
- );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->header('X-Class-Forward-Test-Method'), 1,
- 'Test Method' );
- }
-
-}
@@ -1,83 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-our $iters;
-
-BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
-
-use Test::More tests => 18*$iters;
-use Catalyst::Test 'TestApp';
-
-if ( $ENV{CAT_BENCHMARK} ) {
- require Benchmark;
- Benchmark::timethis( $iters, \&run_tests );
-}
-else {
- for ( 1 .. $iters ) {
- run_tests();
- }
-}
-
-sub run_tests {
- {
- ok( my $response = request('http://localhost/action_global_one'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'),
- 'action_global_one', 'Test Action' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::Global',
- 'Test Class'
- );
- like(
- $response->content,
- qr/^bless\( .* 'Catalyst::Request' \)$/s,
- 'Content is a serialized Catalyst::Request'
- );
- }
-
- {
- ok( my $response = request('http://localhost/action_global_two'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'),
- 'action_global_two', 'Test Action' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::Global',
- 'Test Class'
- );
- like(
- $response->content,
- qr/^bless\( .* 'Catalyst::Request' \)$/s,
- 'Content is a serialized Catalyst::Request'
- );
- }
-
- {
- ok( my $response = request('http://localhost/action_global_three'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'),
- 'action_global_three', 'Test Action' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::Global',
- 'Test Class'
- );
- like(
- $response->content,
- qr/^bless\( .* 'Catalyst::Request' \)$/s,
- 'Content is a serialized Catalyst::Request'
- );
- }
-}
@@ -1,100 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-our $iters;
-
-BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
-
-use Test::More tests => 20*$iters;
-use Catalyst::Test 'TestApp';
-
-if ( $ENV{CAT_BENCHMARK} ) {
- require Benchmark;
- Benchmark::timethis( $iters, \&run_tests );
-}
-else {
- for ( 1 .. $iters ) {
- run_tests();
- }
-}
-
-sub run_tests {
- # test root index
- {
- my @expected = qw[
- TestApp->index
- TestApp->end
- ];
-
- my $expected = join( ", ", @expected );
- ok( my $response = request('http://localhost/'), 'root index' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, 'root index', 'root index ok' );
-
- ok( $response = request('http://localhost'), 'root index no slash' );
- is( $response->content, 'root index', 'root index no slash ok' );
- }
-
- # test first-level controller index
- {
- my @expected = qw[
- TestApp::Controller::Index->index
- TestApp->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/index/'), 'first-level controller index' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, 'Index index', 'first-level controller index ok' );
-
- ok( $response = request('http://localhost/index'), 'first-level controller index no slash' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, 'Index index', 'first-level controller index no slash ok' );
- }
-
- # test second-level controller index
- {
- my @expected = qw[
- TestApp::Controller::Action::Index->begin
- TestApp::Controller::Action::Index->index
- TestApp->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/action/index/'), 'second-level controller index' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, 'Action-Index index', 'second-level controller index ok' );
-
- ok( $response = request('http://localhost/action/index'), 'second-level controller index no slash' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, 'Action-Index index', 'second-level controller index no slash ok' );
- }
-
- # test controller default when index is present
- {
- my @expected = qw[
- TestApp::Controller::Action::Index->begin
- TestApp::Controller::Action::Index->default
- TestApp->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/action/index/foo'), 'default with index' );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- is( $response->content, "Error - TestApp::Controller::Action\n", 'default with index ok' );
- }
-}
@@ -1,119 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-our $iters;
-
-BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
-
-use Test::More tests => 21*$iters;
-use Catalyst::Test 'TestApp';
-
-if ( $ENV{CAT_BENCHMARK} ) {
- require Benchmark;
- Benchmark::timethis( $iters, \&run_tests );
-}
-else {
- for ( 1 .. $iters ) {
- run_tests();
- }
-}
-
-sub run_tests {
- {
- my @expected = qw[
- TestApp::Controller::Action::Inheritance->begin
- TestApp::Controller::Action::Inheritance->auto
- TestApp::Controller::Action::Inheritance->default
- TestApp::View::Dump::Request->process
- TestApp::Controller::Action::Inheritance->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/action/inheritance'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'), 'default', 'Test Action' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::Inheritance',
- 'Test Class'
- );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- like(
- $response->content,
- qr/^bless\( .* 'Catalyst::Request' \)$/s,
- 'Content is a serialized Catalyst::Request'
- );
- }
-
- {
- my @expected = qw[
- TestApp::Controller::Action::Inheritance::A->begin
- TestApp::Controller::Action::Inheritance->auto
- TestApp::Controller::Action::Inheritance::A->auto
- TestApp::Controller::Action::Inheritance::A->default
- TestApp::View::Dump::Request->process
- TestApp::Controller::Action::Inheritance::A->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/action/inheritance/a'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'), 'default', 'Test Action' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::Inheritance::A',
- 'Test Class'
- );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- like(
- $response->content,
- qr/^bless\( .* 'Catalyst::Request' \)$/s,
- 'Content is a serialized Catalyst::Request'
- );
- }
-
- {
- my @expected = qw[
- TestApp::Controller::Action::Inheritance::A::B->begin
- TestApp::Controller::Action::Inheritance->auto
- TestApp::Controller::Action::Inheritance::A->auto
- TestApp::Controller::Action::Inheritance::A::B->auto
- TestApp::Controller::Action::Inheritance::A::B->default
- TestApp::View::Dump::Request->process
- TestApp::Controller::Action::Inheritance::A::B->end
- ];
-
- my $expected = join( ", ", @expected );
-
- ok( my $response = request('http://localhost/action/inheritance/a/b'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'), 'default', 'Test Action' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::Inheritance::A::B',
- 'Test Class'
- );
- is( $response->header('X-Catalyst-Executed'),
- $expected, 'Executed actions' );
- like(
- $response->content,
- qr/^bless\( .* 'Catalyst::Request' \)$/s,
- 'Content is a serialized Catalyst::Request'
- );
- }
-}
@@ -1,138 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-our $iters;
-
-BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
-
-use Test::More tests => 32*$iters;
-use Catalyst::Test 'TestApp';
-
-if ( $ENV{CAT_BENCHMARK} ) {
- require Benchmark;
- Benchmark::timethis( $iters, \&run_tests );
-}
-else {
- for ( 1 .. $iters ) {
- run_tests();
- }
-}
-
-sub run_tests {
- {
- ok( my $response = request('http://localhost/action/local/one'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'),
- 'action/local/one', 'Test Action' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::Local',
- 'Test Class'
- );
- like(
- $response->content,
- qr/^bless\( .* 'Catalyst::Request' \)$/s,
- 'Content is a serialized Catalyst::Request'
- );
- }
-
- {
- ok( my $response = request('http://localhost/action/local/two/1/2'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'),
- 'action/local/two', 'Test Action' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::Local',
- 'Test Class'
- );
- like(
- $response->content,
- qr/^bless\( .* 'Catalyst::Request' \)$/s,
- 'Content is a serialized Catalyst::Request'
- );
- }
-
- {
- ok( my $response = request('http://localhost/action/local/two'),
- 'Request' );
- ok( !$response->is_success, 'Request with wrong number of args failed' );
- }
-
- {
- ok( my $response = request('http://localhost/action/local/three'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'),
- 'action/local/three', 'Test Action' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::Local',
- 'Test Class'
- );
- like(
- $response->content,
- qr/^bless\( .* 'Catalyst::Request' \)$/s,
- 'Content is a serialized Catalyst::Request'
- );
- }
-
- {
- ok(
- my $response =
- request('http://localhost/action/local/four/five/six'),
- 'Request'
- );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'),
- 'action/local/four/five/six', 'Test Action' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::Local',
- 'Test Class'
- );
- like(
- $response->content,
- qr/^bless\( .* 'Catalyst::Request' \)$/s,
- 'Content is a serialized Catalyst::Request'
- );
- }
-
- SKIP:
- {
- if ( $ENV{CATALYST_SERVER} ) {
- skip "tests for %2F on remote server", 6;
- }
-
- ok(
- my $response =
- request('http://localhost/action/local/one/foo%2Fbar'),
- 'Request'
- );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'),
- 'action/local/one', 'Test Action' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::Local',
- 'Test Class'
- );
- like(
- $response->content,
- qr~arguments => \[\s*'foo/bar'\s*\]~,
- "Parameters don't split on %2F"
- );
- }
-}
@@ -1,71 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-my $content = q/foo
-bar
-baz
-/;
-
-our $iters;
-
-BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
-
-use Test::More tests => 16*$iters;
-use Catalyst::Test 'TestApp';
-
-if ( $ENV{CAT_BENCHMARK} ) {
- require Benchmark;
- Benchmark::timethis( $iters, \&run_tests );
-}
-else {
- for ( 1 .. $iters ) {
- run_tests();
- }
-}
-
-sub run_tests {
- # Local
- {
- ok(
- my $response =
- request('http://localhost/action/multipath/multipath'),
- 'Request'
- );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->content, $content, 'Content is a stream' );
- }
-
- # Global
- {
- ok( my $response = request('http://localhost/multipath'), 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->content, $content, 'Content is a stream' );
- }
-
- # Path('/multipath1')
- {
- ok( my $response = request('http://localhost/multipath1'), 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->content, $content, 'Content is a stream' );
- }
-
- # Path('multipath2')
- {
- ok(
- my $response =
- request('http://localhost/action/multipath/multipath2'),
- 'Request'
- );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->content, $content, 'Content is a stream' );
- }
-}
@@ -1,127 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-our $iters;
-
-BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
-
-use Test::More tests => 30*$iters;
-use Catalyst::Test 'TestApp';
-
-if ( $ENV{CAT_BENCHMARK} ) {
- require Benchmark;
- Benchmark::timethis( $iters, \&run_tests );
-}
-else {
- for ( 1 .. $iters ) {
- run_tests();
- }
-}
-
-sub run_tests {
- {
- ok(
- my $response =
- request('http://localhost/action/path/a%20path%20with%20spaces'),
- 'Request'
- );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is(
- $response->header('X-Catalyst-Action'),
- 'action/path/a%20path%20with%20spaces',
- 'Test Action'
- );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::Path',
- 'Test Class'
- );
- like(
- $response->content,
- qr/^bless\( .* 'Catalyst::Request' \)$/s,
- 'Content is a serialized Catalyst::Request'
- );
- }
-
- {
- ok( my $response = request('http://localhost/action/path/åäö'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'),
- 'action/path/%C3%A5%C3%A4%C3%B6', 'Test Action' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::Path',
- 'Test Class'
- );
- like(
- $response->content,
- qr/^bless\( .* 'Catalyst::Request' \)$/s,
- 'Content is a serialized Catalyst::Request'
- );
- }
-
- {
- ok( my $response = request('http://localhost/action/path/'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'),
- 'action/path', 'Test Action' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::Path',
- 'Test Class'
- );
- like(
- $response->content,
- qr/^bless\( .* 'Catalyst::Request' \)$/s,
- 'Content is a serialized Catalyst::Request'
- );
- }
-
- {
- ok( my $response = request('http://localhost/action/path/spaces_near_parens_singleq'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'),
- 'action/path/spaces_near_parens_singleq', 'Test Action' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::Path',
- 'Test Class'
- );
- like(
- $response->content,
- qr/^bless\( .* 'Catalyst::Request' \)$/s,
- 'Content is a serialized Catalyst::Request'
- );
- }
-
- {
- ok( my $response = request('http://localhost/action/path/spaces_near_parens_doubleq'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'),
- 'action/path/spaces_near_parens_doubleq', 'Test Action' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::Path',
- 'Test Class'
- );
- like(
- $response->content,
- qr/^bless\( .* 'Catalyst::Request' \)$/s,
- 'Content is a serialized Catalyst::Request'
- );
- }
-}
@@ -1,89 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-our $iters;
-
-BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
-
-use Test::More tests => 24*$iters;
-use Catalyst::Test 'TestApp';
-
-if ( $ENV{CAT_BENCHMARK} ) {
- require Benchmark;
- Benchmark::timethis( $iters, \&run_tests );
-}
-else {
- for ( 1 .. $iters ) {
- run_tests();
- }
-}
-
-sub run_tests {
- {
- ok( my $response = request('http://localhost/action/private/one'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::Private',
- 'Test Class'
- );
- is( $response->content, 'access denied', 'Access' );
- }
-
- {
- ok( my $response = request('http://localhost/action/private/two'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::Private',
- 'Test Class'
- );
- is( $response->content, 'access denied', 'Access' );
- }
-
- {
- ok( my $response = request('http://localhost/three'), 'Request' );
- ok( $response->is_error, 'Response Server Error 5xx' );
- is( $response->content_type, 'text/html', 'Response Content-Type' );
- like(
- $response->header('X-Catalyst-Error'),
- qr/^Unknown resource "three"/,
- 'Catalyst Error'
- );
- }
-
- {
- ok( my $response = request('http://localhost/action/private/four'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::Private',
- 'Test Class'
- );
- is( $response->content, 'access denied', 'Access' );
- }
-
- {
- ok( my $response = request('http://localhost/action/private/five'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::Private',
- 'Test Class'
- );
- is( $response->content, 'access denied', 'Access' );
- }
-}
@@ -1,106 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-our $iters;
-
-BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
-
-use Test::More tests => 28*$iters;
-use Catalyst::Test 'TestApp';
-
-use Catalyst::Request;
-
-if ( $ENV{CAT_BENCHMARK} ) {
- require Benchmark;
- Benchmark::timethis( $iters, \&run_tests );
-}
-else {
- for ( 1 .. $iters ) {
- run_tests();
- }
-}
-
-sub run_tests {
- {
- ok( my $response = request('http://localhost/action/regexp/10/hello'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'),
- '^action/regexp/(\d+)/(\w+)$', 'Test Action' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::Regexp',
- 'Test Class'
- );
- like(
- $response->content,
- qr/^bless\( .* 'Catalyst::Request' \)$/s,
- 'Content is a serialized Catalyst::Request'
- );
- }
-
- {
- ok( my $response = request('http://localhost/action/regexp/hello/10'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'),
- '^action/regexp/(\w+)/(\d+)$', 'Test Action' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::Regexp',
- 'Test Class'
- );
- like(
- $response->content,
- qr/^bless\( .* 'Catalyst::Request' \)$/s,
- 'Content is a serialized Catalyst::Request'
- );
- }
-
- {
- ok( my $response = request('http://localhost/action/regexp/mandatory'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'),
- '^action/regexp/(mandatory)(/optional)?$', 'Test Action' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::Regexp',
- 'Test Class'
- );
- my $content = $response->content;
- my $req = eval $content;
-
- is( scalar @{ $req->captures }, 2, 'number of captures' );
- is( $req->captures->[ 0 ], 'mandatory', 'mandatory capture' );
- ok( !defined $req->captures->[ 1 ], 'optional capture' );
- }
-
- {
- ok( my $response = request('http://localhost/action/regexp/mandatory/optional'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'),
- '^action/regexp/(mandatory)(/optional)?$', 'Test Action' );
- is(
- $response->header('X-Test-Class'),
- 'TestApp::Controller::Action::Regexp',
- 'Test Class'
- );
- my $content = $response->content;
- my $req = eval $content;
-
- is( scalar @{ $req->captures }, 2, 'number of captures' );
- is( $req->captures->[ 0 ], 'mandatory', 'mandatory capture' );
- is( $req->captures->[ 1 ], '/optional', 'optional capture' );
- }
-}
@@ -1,72 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-our $iters;
-
-BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
-
-use Test::More tests => 10*$iters;
-use Catalyst::Test 'TestApp';
-
-if ( $ENV{CAT_BENCHMARK} ) {
- require Benchmark;
- Benchmark::timethis( $iters, \&run_tests );
-}
-else {
- for ( 1 .. $iters ) {
- run_tests();
- }
-}
-
-sub run_tests {
- # test direct streaming
- {
- ok( my $response = request('http://localhost/streaming'), 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
-
- SKIP:
- {
- if ( $ENV{CATALYST_SERVER} ) {
- skip "Using remote server", 1;
- }
-
- # XXX: Length should be undef here, but HTTP::Request::AsCGI sets it
- is( $response->content_length, 12, 'Response Content-Length' );
- }
-
- is( $response->content,, <<'EOF', 'Content is a stream' );
-foo
-bar
-baz
-EOF
- }
-
- # test streaming by passing a handle to $c->res->body
- SKIP:
- {
- if ( $ENV{CATALYST_SERVER} ) {
- skip "Using remote server", 5;
- }
-
- my $file = "$FindBin::Bin/01use.t";
- my $fh = IO::File->new( $file, 'r' );
- my $buffer;
- if ( defined $fh ) {
- $fh->read( $buffer, 1024 );
- $fh->close;
- }
-
- ok( my $response = request('http://localhost/action/streaming/body'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->content_length, -s $file, 'Response Content-Length' );
- is( $response->content, $buffer, 'Content is read from filehandle' );
- }
-}
@@ -1,98 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-use URI::Escape;
-
-our @paths;
-our $iters;
-
-BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1;
-
- # add special paths to test here
- @paths = (
- # all reserved in uri's
- qw~ : / ? [ ] @ ! $ & ' ( ) * + ; = ~, ',' , '#',
-
- # unreserved
- 'a'..'z','A'..'Z',0..9,qw( - . _ ~ ),
- " ",
-
- # just to test %2F/%
- [ qw~ / / ~ ],
-
- # testing %25/%25
- [ qw~ % % ~ ],
- );
-}
-
-use Test::More tests => 6*@paths * $iters;
-use Catalyst::Test 'TestApp';
-
-if ( $ENV{CAT_BENCHMARK} ) {
- require Benchmark;
- Benchmark::timethis( $iters, \&run_tests );
-
- # new dispatcher:
- # 11 wallclock secs (10.14 usr + 0.20 sys = 10.34 CPU) @ 15.18/s (n=157)
- # old dispatcher (r1486):
- # 11 wallclock secs (10.34 usr + 0.20 sys = 10.54 CPU) @ 13.76/s (n=145)
-}
-else {
- for ( 1 .. $iters ) {
- run_tests();
- }
-}
-
-sub run_tests {
- run_test_for($_) for @paths;
-}
-
-sub run_test_for {
- my $test = shift;
-
- my $path;
- if (ref $test) {
- $path = join "/", map uri_escape($_), @$test;
- $test = join '', @$test;
- } else {
- $path = uri_escape($test);
- }
-
- SKIP:
- {
- # Skip %2F, ., [, (, and ) tests on real webservers
- # Both Apache and lighttpd don't seem to like these
- if ( $ENV{CATALYST_SERVER} && $path =~ /(?:%2F|\.|%5B|\(|\))/ ) {
- skip "Skipping $path tests on remote server", 6;
- }
-
- my $response;
-
- ok( $response = request("http://localhost/args/args/$path"), "Requested args for path $path");
-
- is( $response->content, $test, "$test as args" );
-
- undef $response;
-
- ok( $response = request("http://localhost/args/params/$path"), "Requested params for path $path");
-
- is( $response->content, $test, "$test as params" );
-
- undef $response;
-
- if( $test =~ m{/} ) {
- $test =~ s{/}{}g;
- $path = uri_escape( $test );
- }
-
- ok( $response = request("http://localhost/chained/multi_cap/$path/baz"), "Requested capture for path $path");
-
- is( $response->content, join( ', ', split( //, $test ) ) ."; ", "$test as capture" );
- }
-}
-
@@ -1,77 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-use Test::More tests => 18;
-use Catalyst::Test 'TestApp';
-
-use Catalyst::Request;
-use HTTP::Headers;
-use HTTP::Request::Common;
-
-{
- my $creq;
-
- my $request = POST(
- 'http://localhost/dump/request/',
- 'Content-Type' => 'text/plain',
- 'Content' => 'Hello Catalyst'
- );
-
- ok( my $response = request($request), 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- like( $response->content, qr/'Catalyst::Request'/,
- 'Content is a serialized Catalyst::Request' );
-
- {
- no strict 'refs';
- ok(
- eval '$creq = ' . $response->content,
- 'Unserialize Catalyst::Request'
- );
- }
-
- isa_ok( $creq, 'Catalyst::Request' );
- is( $creq->method, 'POST', 'Catalyst::Request method' );
- is( $creq->content_type, 'text/plain', 'Catalyst::Request Content-Type' );
- is( $creq->content_length, $request->content_length,
- 'Catalyst::Request Content-Length' );
-}
-
-{
- my $creq;
-
- my $request = POST(
- 'http://localhost/dump/request/',
- 'Content-Type' => 'text/plain',
- 'Content' => 'x' x 100_000
- );
-
- ok( my $response = request($request), 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- like(
- $response->content,
- qr/^bless\( .* 'Catalyst::Request' \)$/s,
- 'Content is a serialized Catalyst::Request'
- );
-
- {
- no strict 'refs';
- ok(
- eval '$creq = ' . $response->content,
- 'Unserialize Catalyst::Request'
- );
- }
-
- isa_ok( $creq, 'Catalyst::Request' );
- is( $creq->method, 'POST', 'Catalyst::Request method' );
- is( $creq->content_type, 'text/plain', 'Catalyst::Request Content-Type' );
- is( $creq->content_length, $request->content_length,
- 'Catalyst::Request Content-Length' );
-}
@@ -1,45 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-use Test::More tests => 13;
-use Catalyst::Test 'TestApp';
-
-use Catalyst::Request;
-use CGI::Simple::Cookie;
-use HTTP::Headers;
-use HTTP::Request::Common;
-use URI;
-
-{
- my $creq;
-
- my $request = GET( 'http://localhost/dump/request',
- 'Cookie' => 'Catalyst=Cool; Cool=Catalyst', );
-
- ok( my $response = request($request), 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- like( $response->content, qr/'Catalyst::Request'/,
- 'Content is a serialized Catalyst::Request' );
- ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
- isa_ok( $creq, 'Catalyst::Request' );
- isa_ok( $creq->cookies->{Catalyst}, 'CGI::Simple::Cookie',
- 'Cookie Catalyst' );
- is( $creq->cookies->{Catalyst}->name, 'Catalyst', 'Cookie Catalyst name' );
- is( $creq->cookies->{Catalyst}->value, 'Cool', 'Cookie Catalyst value' );
- isa_ok( $creq->cookies->{Cool}, 'CGI::Simple::Cookie', 'Cookie Cool' );
- is( $creq->cookies->{Cool}->name, 'Cool', 'Cookie Cool name' );
- is( $creq->cookies->{Cool}->value, 'Catalyst', 'Cookie Cool value' );
-
- my $cookies = {
- Catalyst => $creq->cookies->{Catalyst},
- Cool => $creq->cookies->{Cool}
- };
-
- is_deeply( $creq->cookies, $cookies, 'Cookies' );
-}
@@ -1,71 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-use Test::More tests => 17;
-use Catalyst::Test 'TestApp';
-
-use Catalyst::Request;
-use HTTP::Headers;
-use HTTP::Request::Common;
-
-{
- my $creq;
-
- my $request = GET( 'http://localhost/dump/request',
- 'User-Agent' => 'MyAgen/1.0',
- 'X-Whats-Cool' => 'Catalyst',
- 'X-Multiple' => [ 1 .. 5 ],
- 'X-Forwarded-Host' => 'frontend.server.com',
- 'X-Forwarded-For' => '192.168.1.1, 1.2.3.4',
- );
-
- ok( my $response = request($request), 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- like( $response->content, qr/^bless\( .* 'Catalyst::Request' \)$/s, 'Content is a serialized Catalyst::Request' );
- ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
- isa_ok( $creq, 'Catalyst::Request' );
- isa_ok( $creq->headers, 'HTTP::Headers', 'Catalyst::Request->headers' );
- is( $creq->header('X-Whats-Cool'), $request->header('X-Whats-Cool'), 'Catalyst::Request->header X-Whats-Cool' );
-
- { # Test that multiple headers are joined as per RFC 2616 4.2 and RFC 3875 4.1.18
-
- my $excpected = '1, 2, 3, 4, 5';
- my $got = $creq->header('X-Multiple'); # HTTP::Headers is context sensitive, "force" scalar context
-
- is( $got, $excpected, 'Multiple message-headers are joined as a comma-separated list' );
- }
-
- is( $creq->header('User-Agent'), $request->header('User-Agent'), 'Catalyst::Request->header User-Agent' );
-
- my $host = sprintf( '%s:%d', $request->uri->host, $request->uri->port );
- is( $creq->header('Host'), $host, 'Catalyst::Request->header Host' );
-
- SKIP:
- {
- if ( $ENV{CATALYST_SERVER} && $ENV{CATALYST_SERVER} !~ /127.0.0.1|localhost/ ) {
- skip "Using remote server", 2;
- }
-
- is( $creq->base->host, 'frontend.server.com', 'Catalyst::Request proxied base' );
- is( $creq->address, '1.2.3.4', 'Catalyst::Request proxied address' );
- }
-
- SKIP:
- {
- if ( $ENV{CATALYST_SERVER} ) {
- skip "Using remote server", 4;
- }
- # test that we can ignore the proxy support
- TestApp->config->{ignore_frontend_proxy} = 1;
- ok( $response = request($request), 'Request' );
- ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
- is( $creq->base, 'http://localhost/', 'Catalyst::Request non-proxied base' );
- is( $creq->address, '127.0.0.1', 'Catalyst::Request non-proxied address' );
- }
-}
@@ -1,129 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-use Test::More tests => 35;
-use Catalyst::Test 'TestApp';
-
-use Catalyst::Request;
-use HTTP::Headers;
-use HTTP::Request::Common;
-
-{
- my $creq;
-
- my $parameters = { 'a' => [qw(A b C d E f G)], };
-
- my $query = join( '&', map { 'a=' . $_ } @{ $parameters->{a} } );
-
- ok( my $response = request("http://localhost/dump/request?$query"),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- like(
- $response->content,
- qr/^bless\( .* 'Catalyst::Request' \)$/s,
- 'Content is a serialized Catalyst::Request'
- );
- ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
- isa_ok( $creq, 'Catalyst::Request' );
- is( $creq->method, 'GET', 'Catalyst::Request method' );
- is_deeply( $creq->{parameters}, $parameters,
- 'Catalyst::Request parameters' );
-}
-
-{
- my $creq;
- ok( my $response = request("http://localhost/dump/request?q=foo%2bbar"),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- ok( eval '$creq = ' . $response->content );
- is $creq->{parameters}->{q}, 'foo+bar', '%2b not double decoded';
-}
-
-{
- my $creq;
-
- my $parameters = {
- 'a' => [qw(A b C d E f G)],
- '%' => [ '%', '"', '& - &' ],
- 'blank' => '',
- };
-
- my $request = POST(
- 'http://localhost/dump/request/a/b?a=1&a=2&a=3',
- 'Content' => $parameters,
- 'Content-Type' => 'application/x-www-form-urlencoded'
- );
-
- unshift( @{ $parameters->{a} }, 1, 2, 3 );
-
- ok( my $response = request($request), 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- like(
- $response->content,
- qr/^bless\( .* 'Catalyst::Request' \)$/s,
- 'Content is a serialized Catalyst::Request'
- );
- ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
- isa_ok( $creq, 'Catalyst::Request' );
- is( $creq->method, 'POST', 'Catalyst::Request method' );
- is_deeply( $creq->{parameters}, $parameters,
- 'Catalyst::Request parameters' );
- is_deeply( $creq->arguments, [qw(a b)], 'Catalyst::Request arguments' );
- is_deeply( $creq->{uploads}, {}, 'Catalyst::Request uploads' );
- is_deeply( $creq->cookies, {}, 'Catalyst::Request cookie' );
-}
-
-# http://dev.catalyst.perl.org/ticket/37
-# multipart/form-data parameters that contain 'http://'
-# was an HTTP::Message bug, but HTTP::Body handles it properly now
-{
- my $creq;
-
- my $parameters = {
- 'url' => 'http://www.google.com',
- 'blank' => '',
- };
-
- my $request = POST( 'http://localhost/dump/request',
- 'Content-Type' => 'multipart/form-data',
- 'Content' => $parameters,
- );
-
- ok( my $response = request($request), 'Request' );
- ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
- is_deeply( $creq->{parameters}, $parameters, 'Catalyst::Request parameters' );
-}
-
-# raw query string support
-{
- my $creq;
-
- my $parameters = {
- a => 1,
- blank => '',
- };
-
- my $request = POST(
- 'http://localhost/dump/request/a/b?query+string',
- 'Content' => $parameters,
- 'Content-Type' => 'application/x-www-form-urlencoded'
- );
-
- ok( my $response = request($request), 'Request' );
- ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
- is( $creq->{uri}->query, 'query+string', 'Catalyst::Request POST query_string' );
- is( $creq->query_keywords, 'query string', 'Catalyst::Request query_keywords' );
- is_deeply( $creq->{parameters}, $parameters, 'Catalyst::Request parameters' );
-
- ok( $response = request('http://localhost/dump/request/a/b?x=1&y=1&z=1'), 'Request' );
- ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
- is( $creq->{uri}->query, 'x=1&y=1&z=1', 'Catalyst::Request GET query_string' );
-}
@@ -1,244 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-use Test::More tests => 75;
-use Catalyst::Test 'TestApp';
-
-use Catalyst::Request;
-use Catalyst::Request::Upload;
-use HTTP::Headers;
-use HTTP::Headers::Util 'split_header_words';
-use HTTP::Request::Common;
-
-{
- my $creq;
-
- my $request = POST(
- 'http://localhost/dump/request/',
- 'Content-Type' => 'form-data',
- 'Content' => [
- 'live_engine_request_cookies.t' =>
- ["$FindBin::Bin/live_engine_request_cookies.t"],
- 'live_engine_request_headers.t' =>
- ["$FindBin::Bin/live_engine_request_headers.t"],
- 'live_engine_request_uploads.t' =>
- ["$FindBin::Bin/live_engine_request_uploads.t"],
- ]
- );
-
- ok( my $response = request($request), 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- like(
- $response->content,
- qr/^bless\( .* 'Catalyst::Request' \)$/s,
- 'Content is a serialized Catalyst::Request'
- );
-
- {
- no strict 'refs';
- ok(
- eval '$creq = ' . $response->content,
- 'Unserialize Catalyst::Request'
- );
- }
-
- isa_ok( $creq, 'Catalyst::Request' );
- is( $creq->method, 'POST', 'Catalyst::Request method' );
- is( $creq->content_type, 'multipart/form-data',
- 'Catalyst::Request Content-Type' );
- is( $creq->content_length, $request->content_length,
- 'Catalyst::Request Content-Length' );
-
- for my $part ( $request->parts ) {
-
- my $disposition = $part->header('Content-Disposition');
- my %parameters = @{ ( split_header_words($disposition) )[0] };
-
- my $upload = $creq->{uploads}->{ $parameters{filename} };
-
- isa_ok( $upload, 'Catalyst::Request::Upload' );
-
- is( $upload->type, $part->content_type, 'Upload Content-Type' );
- is( $upload->size, length( $part->content ), 'Upload Content-Length' );
-
- # make sure upload is accessible via legacy params->{$file}
- is( $creq->{parameters}->{ $upload->filename },
- $upload->filename, 'legacy param method ok' );
-
- ok( !-e $upload->tempname, 'Upload temp file was deleted' );
- }
-}
-
-{
- my $creq;
-
- my $request = POST(
- 'http://localhost/dump/request/',
- 'Content-Type' => 'multipart/form-data',
- 'Content' => [
- 'testfile' => ["$FindBin::Bin/live_engine_request_cookies.t"],
- 'testfile' => ["$FindBin::Bin/live_engine_request_headers.t"],
- 'testfile' => ["$FindBin::Bin/live_engine_request_uploads.t"],
- ]
- );
-
- ok( my $response = request($request), 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- like(
- $response->content,
- qr/^bless\( .* 'Catalyst::Request' \)$/s,
- 'Content is a serialized Catalyst::Request'
- );
-
- {
- no strict 'refs';
- ok(
- eval '$creq = ' . $response->content,
- 'Unserialize Catalyst::Request'
- );
- }
-
- isa_ok( $creq, 'Catalyst::Request' );
- is( $creq->method, 'POST', 'Catalyst::Request method' );
- is( $creq->content_type, 'multipart/form-data',
- 'Catalyst::Request Content-Type' );
- is( $creq->content_length, $request->content_length,
- 'Catalyst::Request Content-Length' );
-
- my @parts = $request->parts;
-
- for ( my $i = 0 ; $i < @parts ; $i++ ) {
-
- my $part = $parts[$i];
- my $disposition = $part->header('Content-Disposition');
- my %parameters = @{ ( split_header_words($disposition) )[0] };
-
- my $upload = $creq->{uploads}->{ $parameters{name} }->[$i];
-
- isa_ok( $upload, 'Catalyst::Request::Upload' );
- is( $upload->type, $part->content_type, 'Upload Content-Type' );
- is( $upload->filename, $parameters{filename}, 'Upload filename' );
- is( $upload->size, length( $part->content ), 'Upload Content-Length' );
-
- ok( !-e $upload->tempname, 'Upload temp file was deleted' );
- }
-}
-
-{
- my $creq;
-
- my $request = POST(
- 'http://localhost/engine/request/uploads/slurp',
- 'Content-Type' => 'multipart/form-data',
- 'Content' =>
- [ 'slurp' => ["$FindBin::Bin/live_engine_request_uploads.t"], ]
- );
-
- ok( my $response = request($request), 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->content, ( $request->parts )[0]->content, 'Content' );
-}
-
-{
- my $request = POST(
- 'http://localhost/dump/request',
- 'Content-Type' => 'multipart/form-data',
- 'Content' =>
- [ 'file' => ["$FindBin::Bin/catalyst_130pix.gif"], ]
- );
-
- # LWP will auto-correct Content-Length when using a remote server
- SKIP:
- {
- if ( $ENV{CATALYST_SERVER} ) {
- skip 'Using remote server', 2;
- }
-
- # Sending wrong Content-Length here and see if subequent requests fail
- $request->header('Content-Length' => $request->header('Content-Length') + 1);
-
- ok( my $response = request($request), 'Request' );
- ok( !$response->is_success, 'Response Error' );
- }
-
- $request = POST(
- 'http://localhost/dump/request',
- 'Content-Type' => 'multipart/form-data',
- 'Content' =>
- [ 'file1' => ["$FindBin::Bin/catalyst_130pix.gif"],
- 'file2' => ["$FindBin::Bin/catalyst_130pix.gif"], ]
- );
-
- ok( my $response = request($request), 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- like( $response->content, qr/file1 => bless/, 'Upload with name file1');
- like( $response->content, qr/file2 => bless/, 'Upload with name file2');
-}
-
-{
- my $creq;
-
- my $request = POST(
- 'http://localhost/dump/request/',
- 'Content-Type' => 'form-data',
- 'Content' => [
- 'testfile' => 'textfield value',
- 'testfile' => ["$FindBin::Bin/catalyst_130pix.gif"],
- ]
- );
-
- ok( my $response = request($request), 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- like(
- $response->content,
- qr/^bless\( .* 'Catalyst::Request' \)$/s,
- 'Content is a serialized Catalyst::Request'
- );
-
- {
- no strict 'refs';
- ok(
- eval '$creq = ' . $response->content,
- 'Unserialize Catalyst::Request'
- );
- }
-
- isa_ok( $creq, 'Catalyst::Request' );
- is( $creq->method, 'POST', 'Catalyst::Request method' );
- is( $creq->content_type, 'multipart/form-data',
- 'Catalyst::Request Content-Type' );
- is( $creq->content_length, $request->content_length,
- 'Catalyst::Request Content-Length' );
-
- my $param = $creq->{parameters}->{testfile};
-
- ok( @$param == 2, '2 values' );
- is( $param->[0], 'textfield value', 'correct value' );
- like( $param->[1], qr/\Qcatalyst_130pix.gif/, 'filename' );
-
- for my $part ( $request->parts ) {
-
- my $disposition = $part->header('Content-Disposition');
- my %parameters = @{ ( split_header_words($disposition) )[0] };
-
- next unless exists $parameters{filename};
-
- my $upload = $creq->{uploads}->{ $parameters{name} };
-
- isa_ok( $upload, 'Catalyst::Request::Upload' );
-
- is( $upload->type, $part->content_type, 'Upload Content-Type' );
- is( $upload->size, length( $part->content ), 'Upload Content-Length' );
- is( $upload->filename, 'catalyst_130pix.gif' );
- }
-}
@@ -1,121 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-use Test::More tests => 49;
-use Catalyst::Test 'TestApp';
-use Catalyst::Request;
-
-my $creq;
-
-# test that the path can be changed
-{
- ok( my $response = request('http://localhost/engine/request/uri/change_path'), 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
- like( $creq->uri, qr{/my/app/lives/here$}, 'URI contains new path' );
-}
-
-# test that path properly removes the base location
-{
- ok( my $response = request('http://localhost/engine/request/uri/change_base'), 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
- like( $creq->base, qr{/new/location}, 'Base URI contains new location' );
- is( $creq->path, 'engine/request/uri/change_base', 'URI contains correct path' );
-}
-
-# test that base + path is correct
-{
- ok( my $response = request('http://localhost/engine/request/uri'), 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
- is( $creq->base . $creq->path, $creq->uri, 'Base + Path ok' );
-}
-
-# test base is correct for HTTPS URLs
-SKIP:
-{
- if ( $ENV{CATALYST_SERVER} ) {
- skip 'Using remote server', 5;
- }
-
- local $ENV{HTTPS} = 'on';
- ok( my $response = request('https://localhost/engine/request/uri'), 'HTTPS Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
- is( $creq->base, 'https://localhost/', 'HTTPS base ok' );
- is( $creq->uri, 'https://localhost/engine/request/uri', 'HTTPS uri ok' );
-}
-
-# test that we can use semi-colons as separators
-{
- my $parameters = {
- a => [ qw/1 2/ ],
- b => 3,
- };
-
- ok( my $response = request('http://localhost/engine/request/uri?a=1;a=2;b=3'), 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
- is( $creq->{uri}->query, 'a=1;a=2;b=3', 'Query string ok' );
- is_deeply( $creq->{parameters}, $parameters, 'Parameters ok' );
-}
-
-# test that query params are unescaped properly
-{
- ok( my $response = request('http://localhost/engine/request/uri?text=Catalyst%20Rocks'), 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
- is( $creq->{uri}->query, 'text=Catalyst%20Rocks', 'Query string ok' );
- is( $creq->{parameters}->{text}, 'Catalyst Rocks', 'Unescaped param ok' );
-}
-
-# test that uri_with adds params
-{
- ok( my $response = request('http://localhost/engine/request/uri/uri_with'), 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- ok( !defined $response->header( 'X-Catalyst-Param-a' ), 'param "a" ok' );
- is( $response->header( 'X-Catalyst-Param-b' ), '1', 'param "b" ok' );
-}
-
-# test that uri_with adds params (and preserves)
-{
- ok( my $response = request('http://localhost/engine/request/uri/uri_with?a=1'), 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->header( 'X-Catalyst-Param-a' ), '1', 'param "a" ok' );
- is( $response->header( 'X-Catalyst-Param-b' ), '1', 'param "b" ok' );
-}
-
-# test that uri_with replaces params (and preserves)
-{
- ok( my $response = request('http://localhost/engine/request/uri/uri_with?a=1&b=2'), 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->header( 'X-Catalyst-Param-a' ), '1', 'param "a" ok' );
- is( $response->header( 'X-Catalyst-Param-b' ), '1', 'param "b" ok' );
-}
-
-# test that uri_with replaces params (and preserves)
-{
- ok( my $response = request('http://localhost/engine/request/uri/uri_with_object'), 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- like( $response->header( 'X-Catalyst-Param-a' ), qr(https?://localhost[^/]*/), 'param "a" ok' );
-}
-
-# test that uri_with is utf8 safe
-{
- ok( my $response = request("http://localhost/engine/request/uri/uri_with_utf8"), 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- like( $response->header( 'X-Catalyst-uri-with' ), qr/%E2%98%A0$/, 'uri_with ok' );
-}
-
-# test with undef -- no warnings should be thrown
-{
- ok( my $response = request("http://localhost/engine/request/uri/uri_with_undef"), 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->header( 'X-Catalyst-warnings' ), 0, 'no warnings emitted' );
-}
@@ -1,73 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-use Test::More tests => 15;
-use Catalyst::Test 'TestApp';
-use HTTP::Headers::Util 'split_header_words';
-
-my $expected = {
- Catalyst => [qw|Catalyst Cool path /bah|],
- Cool => [qw|Cool Catalyst path /|]
-};
-
-{
- ok( my $response = request('http://localhost/engine/response/cookies/one'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'),
- 'engine/response/cookies/one', 'Test Action' );
-
- my $cookies = {};
-
- for my $string ( $response->header('Set-Cookie') ) {
- my $cookie = [ split_header_words $string];
- $cookies->{ $cookie->[0]->[0] } = $cookie->[0];
- }
-
- is_deeply( $cookies, $expected, 'Response Cookies' );
-}
-
-{
- ok( my $response = request('http://localhost/engine/response/cookies/two'),
- 'Request' );
- ok( $response->is_redirect, 'Response Redirection 3xx' );
- is( $response->code, 302, 'Response Code' );
- is( $response->header('X-Catalyst-Action'),
- 'engine/response/cookies/two', 'Test Action' );
-
- my $cookies = {};
-
- for my $string ( $response->header('Set-Cookie') ) {
- my $cookie = [ split_header_words $string];
- $cookies->{ $cookie->[0]->[0] } = $cookie->[0];
- }
-
- is_deeply( $cookies, $expected, 'Response Cookies' );
-}
-
-{
- ok( my $response = request('http://localhost/engine/response/cookies/three'),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'),
- 'engine/response/cookies/three', 'Test Action' );
-
- my $cookies = {};
-
- for my $string ( $response->header('Set-Cookie') ) {
- my $cookie = [ split_header_words $string];
- $cookies->{ $cookie->[0]->[0] } = $cookie->[0];
- }
-
- is_deeply( $cookies, {
- hash => [ qw(hash a&b&c path /) ],
- this_is_the_real_name => [ qw(this_is_the_real_name foo&bar path /) ], # not "object"
- }, 'Response Cookies' );
-}
@@ -1,60 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-use Test::More tests => 18;
-use Catalyst::Test 'TestApp';
-
-close STDERR; # i'm naughty :)
-
-{
- ok( my $response = request('http://localhost/engine/response/errors/one'),
- 'Request' );
- ok( $response->is_error, 'Response Server Error 5xx' );
- is( $response->code, 500, 'Response Code' );
- is( $response->content_type, 'text/html', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'),
- 'engine/response/errors/one', 'Test Action' );
- like(
- $response->header('X-Catalyst-Error'),
- qr/^Caught exception/,
- 'Catalyst Error'
- );
-}
-
-{
- ok( my $response = request('http://localhost/engine/response/errors/two'),
- 'Request' );
- ok( $response->is_error, 'Response Server Error 5xx' );
- is( $response->code, 500, 'Response Code' );
- is( $response->content_type, 'text/html', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'),
- 'engine/response/errors/two', 'Test Action' );
- like(
- $response->header('X-Catalyst-Error'),
- qr/^Couldn't forward to/,
- 'Catalyst Error'
- );
-}
-
-{
- ok( my $response = request('http://localhost/engine/response/errors/three'),
- 'Request' );
- ok( $response->is_error, 'Response Server Error 5xx' );
- is( $response->code, 500, 'Response Code' );
- is( $response->content_type, 'text/html', 'Response Content-Type' );
- is(
- $response->header('X-Catalyst-Action'),
- 'engine/response/errors/three',
- 'Test Action'
- );
- like(
- $response->header('X-Catalyst-Error'),
- qr/I'm going to die!/,
- 'Catalyst Error'
- );
-}
@@ -1,58 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-use Test::More tests => 18;
-use Catalyst::Test 'TestApp';
-use HTTP::Request::Common;
-
-my $content_length;
-
-foreach my $method qw(HEAD GET) {
- my $expected = join( ', ', 1 .. 10 );
-
- my $request = HTTP::Request::Common->can($method)
- ->( 'http://localhost/engine/response/headers/one' );
-
- ok( my $response = request($request), 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->code, 200, 'Response Code' );
- is( $response->header('X-Catalyst-Action'),
- 'engine/response/headers/one', 'Test Action' );
- is( $response->header('X-Header-Catalyst'),
- 'Cool', 'Response Header X-Header-Catalyst' );
- is( $response->header('X-Header-Cool'),
- 'Catalyst', 'Response Header X-Header-Cool' );
- is( $response->header('X-Header-Numbers'),
- $expected, 'Response Header X-Header-Numbers' );
-
- use bytes;
- if ( $method eq 'HEAD' ) {
- $content_length = $response->header('Content-Length');
- ok( $content_length > 0, 'Response Header Content-Length' );
- is( length($response->content),
- 0,
- 'HEAD method content is empty' );
- }
- elsif ( $method eq 'GET' ) {
- # method name is echo'd back in content-body, which
- # accounts for difference in content length. In normal
- # cases the Content-Length should be the same regardless
- # of if its a GET or HEAD request.
- SKIP:
- {
- if ( $ENV{CATALYST_SERVER} ) {
- skip "Using remote server", 2;
- }
- is( $response->header('Content-Length'),
- $content_length - 1, 'Response Header Content-Length' );
- is( length($response->content),
- $response->header('Content-Length'),
- 'GET method content' );
- }
- }
-}
@@ -1,27 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-use Test::More tests => 6;
-use Catalyst::Test 'TestApp';
-
-# phaylon noticed that refactored was truncating output on large images.
-# This test tests 100K and 1M output content.
-
-my $expected = {
- one => 'x' x (100 * 1024),
- two => 'y' x (1024 * 1024),
-};
-
-for my $action ( keys %{$expected} ) {
- ok( my $response = request('http://localhost/engine/response/large/' . $action ),
- 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
-
- is( length( $response->content ), length( $expected->{$action} ), 'Length OK' );
-}
-
@@ -1,48 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-use Test::More tests => 26;
-use Catalyst::Test 'TestApp';
-
-{
- ok( my $response = request('http://localhost/engine/response/redirect/one'), 'Request' );
- ok( $response->is_redirect, 'Response Redirection 3xx' );
- is( $response->code, 302, 'Response Code' );
- is( $response->header('X-Catalyst-Action'), 'engine/response/redirect/one', 'Test Action' );
- is( $response->header('Location'), '/test/writing/is/boring', 'Response Header Location' );
- ok( $response->header('Content-Length'), '302 Redirect contains Content-Length' );
- ok( $response->content, '302 Redirect contains a response body' );
-}
-
-{
- ok( my $response = request('http://localhost/engine/response/redirect/two'), 'Request' );
- ok( $response->is_redirect, 'Response Redirection 3xx' );
- is( $response->code, 302, 'Response Code' );
- is( $response->header('X-Catalyst-Action'), 'engine/response/redirect/two', 'Test Action' );
- is( $response->header('Location'), 'http://www.google.com/', 'Response Header Location' );
-}
-
-{
- ok( my $response = request('http://localhost/engine/response/redirect/three'), 'Request' );
- ok( $response->is_redirect, 'Response Redirection 3xx' );
- is( $response->code, 301, 'Response Code' );
- is( $response->header('X-Catalyst-Action'), 'engine/response/redirect/three', 'Test Action' );
- is( $response->header('Location'), 'http://www.google.com/', 'Response Header Location' );
- ok( $response->header('Content-Length'), '301 Redirect contains Content-Length' );
- ok( $response->content, '301 Redirect contains a response body' );
-}
-
-{
- ok( my $response = request('http://localhost/engine/response/redirect/four'), 'Request' );
- ok( $response->is_redirect, 'Response Redirection 3xx' );
- is( $response->code, 307, 'Response Code' );
- is( $response->header('X-Catalyst-Action'), 'engine/response/redirect/four', 'Test Action' );
- is( $response->header('Location'), 'http://www.google.com/', 'Response Header Location' );
- ok( $response->header('Content-Length'), '307 Redirect contains Content-Length' );
- ok( $response->content, '307 Redirect contains a response body' );
-}
@@ -1,55 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-use Test::More tests => 30;
-use Catalyst::Test 'TestApp';
-
-{
- ok( my $response = request('http://localhost/engine/response/status/s200'), 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- is( $response->code, 200, 'Response Code' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'), 'engine/response/status/s200', 'Test Action' );
- like( $response->content, qr/^200/, 'Response Content' );
-}
-
-{
- ok( my $response = request('http://localhost/engine/response/status/s400'), 'Request' );
- ok( $response->is_error, 'Response Client Error 4xx' );
- is( $response->code, 400, 'Response Code' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'), 'engine/response/status/s400', 'Test Action' );
- like( $response->content, qr/^400/, 'Response Content' );
-}
-
-{
- ok( my $response = request('http://localhost/engine/response/status/s403'), 'Request' );
- ok( $response->is_error, 'Response Client Error 4xx' );
- is( $response->code, 403, 'Response Code' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'), 'engine/response/status/s403', 'Test Action' );
- like( $response->content, qr/^403/, 'Response Content' );
-}
-
-{
- ok( my $response = request('http://localhost/engine/response/status/s404'), 'Request' );
- ok( $response->is_error, 'Response Client Error 4xx' );
- is( $response->code, 404, 'Response Code' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'), 'engine/response/status/s404', 'Test Action' );
- like( $response->content, qr/^404/, 'Response Content' );
-}
-
-{
- ok( my $response = request('http://localhost/engine/response/status/s500'), 'Request' );
- ok( $response->is_error, 'Response Server Error 5xx' );
- is( $response->code, 500, 'Response Code' );
- is( $response->content_type, 'text/plain', 'Response Content-Type' );
- is( $response->header('X-Catalyst-Action'), 'engine/response/status/s500', 'Test Action' );
- like( $response->content, qr/^500/, 'Response Content' );
-}
@@ -1,19 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-use Test::More tests => 1;
-use Catalyst::Test 'TestApp';
-
-SKIP:
-{
- if ( $ENV{CATALYST_SERVER} ) {
- skip "Using remote server", 1;
- }
- # Allow overriding automatic root.
- is( TestApp->config->{root}, '/some/dir' );
-}
@@ -1,16 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-use Test::More tests => 2;
-use Catalyst::Test 'TestApp';
-
-{
- # Allow overriding automatic root.
- ok( my $response = request('http://localhost/engine/response/headers/one'), 'Request' );
- is( $response->header('X-Catalyst-Plugin-Setup'), '1' );
-}
@@ -1,60 +0,0 @@
-#!/usr/bin/perl
-# live_fork.t
-# Copyright (c) 2006 Jonathan Rockway <jrockway@cpan.org>
-
-=head1 SYNOPSIS
-
-Tests if Catalyst can fork/exec other processes successfully
-
-=cut
-use strict;
-use warnings;
-use Test::More;
-use YAML;
-use FindBin;
-use lib "$FindBin::Bin/lib";
-use Catalyst::Test qw(TestApp);
-
-plan skip_all => 'Using remote server'
- if $ENV{CATALYST_SERVER};
-
-plan skip_all => 'Skipping fork tests: no /bin/ls'
- if !-e '/bin/ls'; # see if /bin/ls exists
-
-plan tests => 13; # otherwise
-
-{
- system:
- ok(my $result = get('/fork/system/%2Fbin%2Fls'), 'system');
- my @result = split /$/m, $result;
- $result = join q{}, @result[-4..-1];
-
- my $result_ref = eval { Load($result) };
- ok($result_ref, 'is YAML');
- is($result_ref->{result}, 0, 'exited OK');
-}
-
-{
- backticks:
- ok(my $result = get('/fork/backticks/%2Fbin%2Fls'), '`backticks`');
- my @result = split /$/m, $result;
- $result = join q{}, @result[-4..-1];
-
- my $result_ref = eval { Load($result) };
- ok($result_ref, 'is YAML');
- is($result_ref->{code}, 0, 'exited successfully');
- like($result_ref->{result}, qr{^/bin/ls[^:]}, 'contains ^/bin/ls$');
- like($result_ref->{result}, qr{\n.*\n}m, 'contains two newlines');
-}
-{
- fork:
- ok(my $result = get('/fork/fork'), 'fork');
- my @result = split /$/m, $result;
- $result = join q{}, @result[-4..-1];
-
- my $result_ref = eval { Load($result) };
- ok($result_ref, 'is YAML');
- isnt($result_ref->{pid}, 0, q{fork's "pid" wasn't 0});
- isnt($result_ref->{pid}, $$, 'fork got a new pid');
- is($result_ref->{result}, 'ok', 'fork was effective');
-}
@@ -1,23 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-use Test::More tests => 3;
-use Catalyst::Test 'TestApp';
-
-SKIP:
-{
- # Net::HTTP::Methods crashes when talking to a remote server because this
- # test causes a very long header line to be sent
- if ( $ENV{CATALYST_SERVER} ) {
- skip 'Using remote server', 3;
- }
-
- ok( my $response = request('http://localhost/loop_test'), 'Request' );
- ok( $response->is_success, 'Response Successful 2xx' );
- ok( $response->header('X-Class-Forward-Test-Method'), 'Loop OK' );
-}
@@ -1,27 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-use Test::More tests => 5;
-use Catalyst::Test 'TestApp';
-
-my @expected = qw[
- Catalyst::Plugin::Test::Errors
- Catalyst::Plugin::Test::Headers
- Catalyst::Plugin::Test::Inline
- Catalyst::Plugin::Test::Plugin
- TestApp::Plugin::FullyQualified
-];
-
-my $expected = join( ", ", @expected );
-
-ok( my $response = request('http://localhost/dump/request'), 'Request' );
-ok( $response->is_success, 'Response Successful 2xx' );
-is( $response->content_type, 'text/plain', 'Response Content-Type' );
-like( $response->content, qr/'Catalyst::Request'/,
- 'Content is a serialized Catalyst::Request' );
-is( $response->header('X-Catalyst-Plugins'), $expected, 'Loaded plugins' );
@@ -1,81 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-use Test::More tests => 28;
-use Catalyst::Test 'TestApp';
-use Data::Dumper;
-
-local $^W = 0;
-
-my $uri_base = 'http://localhost/priorities';
-my @tests = (
-
- # Simple
- 'Regex vs. Local', { path => '/re_vs_loc', expect => 'local' },
- 'Regex vs. LocalRegex', { path => '/re_vs_locre', expect => 'regex' },
- 'Regex vs. Path', { path => '/re_vs_path', expect => 'path' },
- 'Local vs. LocalRegex', { path => '/loc_vs_locre', expect => 'local' },
- 'Local vs. Path 1', { path => '/loc_vs_path1', expect => 'local' },
- 'Local vs. Path 2', { path => '/loc_vs_path2', expect => 'path' },
- 'Path vs. LocalRegex', { path => '/path_vs_locre', expect => 'path' },
-
- # index
- 'index vs. Regex', { path => '/re_vs_index', expect => 'index' },
- 'index vs. Local', { path => '/loc_vs_index', expect => 'index' },
- 'index vs. LocalRegex', { path => '/locre_vs_index', expect => 'index' },
- 'index vs. Path', { path => '/path_vs_index', expect => 'index' },
-
- 'multimethod zero', { path => '/multimethod', expect => 'zero' },
- 'multimethod one', { path => '/multimethod/1', expect => 'one 1' },
- 'multimethod two', { path => '/multimethod/1/2',
- expect => 'two 1 2' },
-);
-
-while ( @tests ) {
-
- my $name = shift @tests;
- my $data = shift @tests;
-
- # Run tests for path with trailing slash and without
- SKIP: for my $req_uri
- (
- join( '' => $uri_base, $data->{ path } ), # Without trailing path
- join( '' => $uri_base, $data->{ path }, '/' ), # With trailing path
- ) {
- my $end_slash = ( $req_uri =~ qr(/$) ? 1 : 0 );
-
- # use slash_expect argument if URI ends with slash
- # and the slash_expect argument is defined
- my $expect = $data->{ expect } || '';
- if ( $end_slash and exists $data->{ slash_expect } ) {
- $expect = $data->{ slash_expect };
- }
-
- # Call the URI on the TestApp
- my $response = request( $req_uri );
-
- # Leave expect out to see the result
- unless ( $expect ) {
- skip 'Nothing expected, winner is ' . $response->content, 1;
- }
-
- # Show error if response was no success
- if ( not $response->is_success ) {
- diag 'Error: ' . $response->headers->{ 'x-catalyst-error' };
- }
-
- # Test if content matches expectations.
- # TODO This might flood the screen with the catalyst please-come-later
- # page. So I don't know it is a good idea.
- is( $response->content, $expect,
- "$name: @{[ $data->{ expect } ]} wins"
- . ( $end_slash ? ' (trailing slash)' : '' )
- );
- }
-}
-
@@ -1,25 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin;
-use lib "$FindBin::Bin/lib";
-
-use Test::More tests => 3;
-use Catalyst::Test 'TestApp';
-
-local $^W = 0;
-
-SKIP:
-{
- # Net::HTTP::Methods crashes when talking to a remote server because this
- # test causes a very long header line to be sent
- if ( $ENV{CATALYST_SERVER} ) {
- skip 'Using remote server', 3;
- }
-
- ok( my $response = request('http://localhost/recursion_test'), 'Request' );
- ok( !$response->is_success, 'Response Not Successful' );
- is( $response->header('X-Catalyst-Error'), 'Deep recursion detected calling "/recursion_test"', 'Deep Recursion Detected' );
-}
@@ -4,7 +4,7 @@
#
# Note, to get this to run properly, you may need to give it the path to your
# httpd.conf:
-#
+#
# perl t/optional/mod_perl-locationmatch.pl -httpd_conf /etc/apache/httpd.conf
#
# For debugging, you can start TestApp and leave it running with
@@ -4,7 +4,7 @@
#
# Note, to get this to run properly, you may need to give it the path to your
# httpd.conf:
-#
+#
# perl t/optional/mod_perl-non-root.pl -httpd_conf /etc/apache/httpd.conf
#
# For debugging, you can start TestApp and leave it running with
@@ -4,7 +4,7 @@
#
# Note, to get this to run properly, you may need to give it the path to your
# httpd.conf:
-#
+#
# perl t/optional/mod_perl.pl -httpd_conf /etc/apache/httpd.conf
#
# For debugging, you can start TestApp and leave it running with
@@ -0,0 +1,16 @@
+
+BEGIN {
+ unless ($ENV{RELEASE_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for release candidate testing');
+ }
+}
+
+use strict;
+use warnings;
+use Test::More;
+
+eval 'use Test::NoTabs';
+plan skip_all => 'Test::NoTabs required' if $@;
+
+all_perl_files_ok();
@@ -0,0 +1,15 @@
+#!perl
+
+BEGIN {
+ unless ($ENV{RELEASE_TESTING}) {
+ require Test::More;
+ Test::More::plan(skip_all => 'these tests are for release candidate testing');
+ }
+}
+
+use Test::More;
+
+eval "use Test::Pod 1.41";
+plan skip_all => "Test::Pod 1.41 required for testing POD" if $@;
+
+all_pod_files_ok();